home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / methods.lsp < prev    next >
Text File  |  1992-09-09  |  122KB  |  2,953 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; METHODS
  32. ;;;
  33. ;;; Methods themselves are simple inanimate objects.  Most properties of
  34. ;;; methods are immutable, methods cannot be reinitialized.  The following
  35. ;;; properties of methods can be changed:
  36. ;;;   METHOD-GENERIC-FUNCTION
  37. ;;;   METHOD-FUNCTION            ??
  38. ;;;   
  39. ;;;
  40.  
  41. (defclass method (metaobject) ()
  42.   (:predicate-name method-p))
  43.  
  44. (defclass standard-method (definition-source-mixin documentation-mixin plist-mixin method)
  45.      ((generic-function
  46.     :initform nil    
  47.     :accessor method-generic-function)
  48. ;     (qualifiers
  49. ;    :initform ()
  50. ;    :initarg  :qualifiers
  51. ;    :reader method-qualifiers)
  52.       (specializers
  53.     :initform ()
  54.     :initarg  :specializers
  55.     :reader method-specializers)
  56.       (lambda-list
  57.     :initform ()
  58.     :initarg  :lambda-list
  59.     :reader method-lambda-list)
  60.       (function
  61.     :initform nil
  62.     :reader method-function)
  63.       (function-name
  64.         :initform nil
  65.         :accessor method-function-name)
  66.       (optimized-function
  67.     :initform nil
  68.     :accessor method-optimized-function)
  69.       (closure-generator
  70.         :initform nil
  71.     :reader method-closure-generator)
  72.       (cached-functions-alist
  73.     :initform nil
  74.         :accessor method-cached-functions-alist
  75.     :documentation
  76.       "Alist of all cached functions of method and the slot-locations/fetchers
  77.            they're cached for.")
  78.       (needs-next-methods-p
  79.         :initform T                             ;Better safe than sorry
  80.         :initarg :needs-next-methods-p
  81.         :reader method-needs-next-methods-p
  82.     :documentation
  83.       "Does method call CALL-NEXT-METHOD or NEXT-METHOD-P?")
  84.       (optimized-slot-indices
  85.         :initform      NIL
  86.         :type          list
  87.         :initarg       :optimized-slot-indices
  88.         :reader        method-optimized-slot-indices
  89.         :documentation
  90.          "List of slot index forms optimized by optimize-instance-access
  91.           for slot-values within the method body.  Each index is in the
  92.           form '(index-var parameter slot-name).")
  93.       (optimized-method-lambda
  94.         :initform      NIL
  95.         :type          list
  96.         :initarg       :optimized-method-lambda
  97.         :reader        method-optimized-method-lambda
  98.         :documentation
  99.          "The optimized PCL method-lambda.  Only stored for methods for
  100.           which store-optimized-method-lambda-p is T.")
  101.       (identifier
  102.         :initform nil
  103.         :initarg :identifier
  104.     :reader method-identifier
  105.     :documentation
  106.          "Symbol identifier for method used for THIS-METHOD and NO-NEXT-METHOD.")
  107.       )
  108.   (:predicate-name standard-method-p))
  109.  
  110. (defclass standard-accessor-method (standard-method)
  111.      ((slot-name :initform nil
  112.          :initarg :slot-name
  113.          :reader accessor-method-slot-name))
  114.   (:predicate-name standard-accessor-method-p))
  115.  
  116. (defclass standard-reader-method (standard-accessor-method) ()
  117.   (:predicate-name standard-reader-method-p))
  118.  
  119. (defclass standard-writer-method (standard-accessor-method) ()
  120.   (:predicate-name standard-writer-method-p))
  121.  
  122. (defclass standard-boundp-method (standard-accessor-method) ()
  123.   (:predicate-name standard-boundp-method-p))
  124.  
  125.  
  126. (defvar *the-class-method*                    (find-class 'method))
  127. (defvar *the-class-standard-method*           (find-class 'standard-method))
  128. (defvar *the-class-standard-reader-method*    (find-class 'standard-reader-method))
  129. (defvar *the-class-standard-writer-method*    (find-class 'standard-writer-method))
  130. (defvar *the-class-standard-boundp-method*    (find-class 'standard-boundp-method))
  131.  
  132. (defmethod accessor-method-slot-definition ((method standard-accessor-method))
  133.   (let ((slot-name    (accessor-method-slot-name method))
  134.         (direct-class (car (last (method-specializers method)))))
  135.     (dolist (direct-slot (class-direct-slots direct-class))
  136.       (when (eq (slot-definition-name direct-slot) slot-name)
  137.         (return direct-slot)))))
  138.  
  139. (defmethod print-object ((method standard-method) stream)
  140.   (printing-random-thing (method stream)
  141.     (let ((generic-function (method-generic-function method))
  142.       (class-name (capitalize-words (class-name (class-of method)))))
  143.       (format stream "~A ~S ~{~S ~}~:S"
  144.           class-name
  145.           (and generic-function (generic-function-name generic-function))
  146.           (method-qualifiers method)
  147.           (unparse-specializers method)))))
  148.  
  149. (defmethod print-object ((method standard-accessor-method) stream)
  150.   (printing-random-thing (method stream)
  151.     (let ((generic-function (method-generic-function method))
  152.       (class-name (capitalize-words (class-name (class-of method)))))
  153.       (format stream "~A ~S, slot:~S, ~:S"
  154.           class-name
  155.           (and generic-function (generic-function-name generic-function))
  156.           (accessor-method-slot-name method)
  157.           (unparse-specializers method)))))
  158.  
  159. (defmethod method-cached-functions ((method standard-method))
  160.   (mapcar #'cdr (slot-value method 'cached-functions-alist)))
  161.  
  162. (defvar *generic-functions-having-cached-closures* NIL)
  163.  
  164. (declaim (ftype (function (T T) (values list list))
  165.                 cached-slot-locations-and-fetchers-from-wrappers))
  166. (defmethod cached-slot-locations-and-fetchers-from-wrappers ((method standard-method)
  167.                                                              wrappers)
  168.   (declare (type list wrappers))
  169.   (if wrappers
  170.       (let ((slot-accesses    (method-optimized-slot-indices method))
  171.             (generic-function (method-generic-function method))
  172.             (lambda-list      (method-lambda-list method))
  173.             (accessed-classes NIL)
  174.             (slot-locations   NIL)
  175.             (slot-fetchers    NIL))
  176.         (declare (type list lambda-list accessed-classes
  177.                             slot-locations slot-fetchers))
  178.         (dolist (slot-access (reverse slot-accesses))
  179.           (let* ((wrapper (nth (the index
  180.                                     (posq (first slot-access) lambda-list))
  181.                                wrappers))
  182.                  (class   (wrapper-class wrapper))
  183.                  (slotd   (find-slot-definition class (second slot-access))))
  184.             (if (and slotd
  185.                      (or *safe-to-use-slot-wrapper-optimizations-p*
  186.                          (slot-values-safe-using-class-p class slotd)))
  187.                 (progn
  188.                   (push (slot-definition-location slotd) slot-locations)
  189.                   (unless (memq class accessed-classes)
  190.                     (let ((cached-in-fns 
  191.                             (fast-slot-value class 'cached-in-generic-functions
  192.                                                    slow-slot-value)))
  193.                       (unless (memq generic-function cached-in-fns)
  194.                         (fast-set-slot-value class 'cached-in-generic-functions
  195.                                              (cons generic-function cached-in-fns)
  196.                                              slow-slot-value)))
  197.                     (push class accessed-classes)))
  198.                 (push NIL slot-locations))
  199.            (push (slots-fetcher class) slot-fetchers)))
  200.         (values slot-locations slot-fetchers))
  201.     (let ((null-list
  202.             (make-list
  203.               (length (the list (method-optimized-slot-indices method))))))
  204.       (values null-list null-list))))
  205.  
  206. (defmethod get-cached-function ((method standard-method)
  207.                                 slot-locations
  208.                                 &optional slot-fetchers)
  209.   (dolist (acons (method-cached-functions-alist method))
  210.     (when (and (list-eq (caar acons) slot-locations)
  211.                (or (equal (cdar acons) slot-fetchers)
  212.                    (null slot-fetchers)))
  213.       (return (cdr acons)))))
  214.  
  215. (defmethod add-cached-function ((method standard-method)
  216.                                 function
  217.                                 slot-locations
  218.                                 &optional slot-fetchers)
  219.   (let ((new-function
  220.           (set-function-name-1 
  221.             (method-function-storage-form function)
  222.             (method-function-name method)
  223.             nil))
  224.         (cached-functions
  225.           (method-cached-functions-alist method)))
  226.     #+(and kcl turbo-closure) (si:turbo-closure new-function)
  227.     (dolist (acons cached-functions
  228.               (setf (method-cached-functions-alist method)
  229.                     (cons (cons (cons slot-locations slot-fetchers) function)
  230.                           cached-functions)))
  231.       (when (and (every #'eql (caar acons) slot-locations)
  232.                  (or (equal (cdar acons) slot-fetchers)
  233.                      (null slot-fetchers)))
  234.         (setf (cdr acons) function)
  235.         (return)))
  236.     (setf (method-function-method new-function) method)
  237.     (pushnew (method-generic-function method)
  238.              *generic-functions-having-cached-closures* :test #'eq)
  239.     new-function))
  240.  
  241.  
  242. ;;; closure-generators are used only by method-function-for-caching
  243. ;;; and make-not-for-caching-method-function (in vector.lisp).
  244.  
  245. (defmethod method-function-for-caching-p ((method standard-method))
  246.   (slot-value method 'closure-generator))
  247.  
  248. (defmethod method-function-for-caching ((method standard-method) wrappers)
  249.   (let* ((closure-generator (slot-value method 'closure-generator)))
  250.     (if closure-generator
  251.         (multiple-value-bind (slot-locations slot-fetchers)
  252.             (cached-slot-locations-and-fetchers-from-wrappers method wrappers)
  253.           (or (get-cached-function method slot-locations slot-fetchers)
  254.               (add-cached-function
  255.                 method
  256.                 (method-function-funcall
  257.                    closure-generator
  258.                    (list slot-locations slot-fetchers method))
  259.                 slot-locations
  260.                 slot-fetchers)))
  261.         (let ((optimized-function (slot-value method 'optimized-function)))
  262.           (if optimized-function
  263.               optimized-function
  264.               (error "~A has neither closure-generator nor optimized-function."
  265.                      method))))))
  266.  
  267. (defvar *cons-global-variable-table* (make-hash-table :test #'eq))
  268.  
  269. (defun get-cons-global-variable (cons)
  270.   (declare (type cons cons))
  271.   (or (gethash cons *cons-global-variable-table*)
  272.       (setf (gethash cons *cons-global-variable-table*)
  273.             (let ((cons-var (gentemp ".CONS")))
  274.               (eval `(defvar ,cons-var))
  275.               (set cons-var cons)
  276.               cons-var))))
  277.  
  278. (defmethod make-cached-method-function-from-stored-lambda
  279.            ((method standard-method)
  280.             slot-locations-and-fetchers)
  281.   (compile-lambda (make-cached-method-lambda-from-stored-lambda
  282.                     method slot-locations-and-fetchers)))
  283.  
  284. (defmethod make-cached-method-lambda-from-stored-lambda
  285.            ((method standard-method)
  286.             slot-locations-and-fetchers)
  287.   (let* ((slot-locations (first  slot-locations-and-fetchers))
  288.          (slot-fetchers  (second slot-locations-and-fetchers))
  289.          (method-lambda  (slot-value method 'optimized-method-lambda))
  290.          (lambda-list    (cadr method-lambda))
  291.          (body           (cddr method-lambda))
  292.          (slot-indices
  293.            (slot-value method 'optimized-slot-indices))
  294.          (used-slot-locations
  295.            (mapcar #'(lambda (loc)
  296.                        (if (consp loc) (get-cons-global-variable loc) loc))
  297.                    slot-locations)))
  298.     (multiple-value-bind (documentation declarations real-body)
  299.        (extract-declarations body)
  300.       (flet ((access-form (x slot location slots-fetcher)
  301.                (cond ((typep location 'fixnum)
  302.                       `(svref (the simple-vector (,slots-fetcher ,x))
  303.                               ,location))
  304.                      ((and (symbolp location) (not (null location)))
  305.                       `(cdr ,location))
  306.                      ((null location)
  307.                       `(fast-slot-value ,x ',slot))
  308.                      (T (error "Unknown slot-location type ~S" location)))))
  309.        `(lambda ,lambda-list
  310.           ,@declarations
  311.           ,@documentation
  312.           (macrolet
  313.            ((optimized-parameter-read (x slot index)
  314.              (declare (ignore index))
  315.              (cond
  316.               ,@(mapcar
  317.                   #'(lambda (slot-index loc slots-fetcher)
  318.                       (let ((slot-param (first slot-index))
  319.                             (slot-name  (second slot-index)))
  320.                        `((and (eq x ',slot-param)
  321.                               (eq (second slot) ',slot-name))
  322.                          ,(if loc
  323.                               ``(let ((.value.
  324.                                         ,',(access-form slot-param slot-name
  325.                                                         loc slots-fetcher)))
  326.                                   (if (eq .value. *slot-unbound*)
  327.                                       (funcall #'slot-value ,',slot-param
  328.                                                ',',slot-name)
  329.                                       .value.))
  330.                               ``(fast-slot-value ,',slot-param
  331.                                                  ',',slot-name)))))
  332.                   slot-indices used-slot-locations slot-fetchers)))
  333.             (optimized-parameter-write (x slot index new)
  334.              (declare (ignore index))
  335.              (cond
  336.               ,@(mapcar
  337.                   #'(lambda (slot-index loc slots-fetcher)
  338.                       (let ((slot-param (first slot-index))
  339.                             (slot-name  (second slot-index)))
  340.                        `((and (eq x ',slot-param)
  341.                               (eq (second slot) ',slot-name))
  342.                          `(setf ,',(access-form slot-param slot-name
  343.                                                 loc slots-fetcher)
  344.                                 ,new))))
  345.                   slot-indices used-slot-locations slot-fetchers)))
  346.             (optimized-parameter-boundp (x slot index)
  347.              (declare (ignore index))
  348.              (cond
  349.               ,@(mapcar
  350.                   #'(lambda (slot-index loc slots-fetcher)
  351.                       (let ((slot-param (first slot-index))
  352.                             (slot-name  (second slot-index)))
  353.                        `((and (eq x ',slot-param)
  354.                               (eq (second slot) ',slot-name))
  355.                          ,(if loc
  356.                               ``(neq ,',(access-form slot-param slot-name
  357.                                                      loc slots-fetcher)
  358.                                      *slot-unbound*)
  359.                               ``(fast-slot-boundp ,',slot-param
  360.                                                   ',',slot-name)))))
  361.                   slot-indices used-slot-locations slot-fetchers))))
  362.            ,@real-body))))))
  363.  
  364.  
  365. (defmethod method-function-for-caching-p ((method standard-accessor-method))
  366.   t)
  367.  
  368. (defmethod method-function-for-caching ((method standard-accessor-method) wrappers)
  369.   (let* ((slot-name (slot-value method 'slot-name))
  370.      (type (cond ((standard-reader-method-p method) 'reader)
  371.              ((standard-writer-method-p method) 'writer)
  372.              ((standard-boundp-method-p method) 'boundp)))
  373.      (class (wrapper-class (if (eq type 'writer) (cadr wrappers) (car wrappers))))
  374.      (slotd (find-slot-definition class slot-name)))
  375.     (if slotd
  376.     (let ((slot-accessor-function (slot-accessor-function slotd type)))
  377.           (pushnew (cons NIL slot-accessor-function)
  378.                    (method-cached-functions-alist method) :test #'equal)
  379.       slot-accessor-function)
  380.     (slot-value method 'optimized-function))))
  381.  
  382. ;;;
  383. ;;; INITIALIZATION
  384. ;;;
  385. ;;; Error checking is done in before methods.  Because of the simplicity of
  386. ;;; standard method objects the standard primary method can fill the slots.
  387. ;;;
  388. ;;; Methods are not reinitializable.
  389. ;;; 
  390.  
  391. (defmethod reinitialize-instance ((method standard-method) &rest initargs)
  392.   (declare (ignore initargs))
  393.   (error "Attempt to reinitialize the method ~S.~%~
  394.           Method objects cannot be reinitialized."
  395.      method))
  396.  
  397. (defmethod legal-lambda-list-p ((object standard-method) x)
  398.   (lambda-list-legal-p x))
  399.  
  400. (defmethod legal-method-function-p ((object standard-method) x)
  401.   (if (or (null x) (functionp x))
  402.       t
  403.       "is not a function"))
  404.  
  405. (defmethod legal-qualifiers-p ((object standard-method) x)
  406.   (flet ((improper-list ()
  407.        (return-from legal-qualifiers-p "Is not a proper list.")))
  408.     (dolist-carefully (q x improper-list)
  409.       (let ((ok (legal-qualifier-p object q)))
  410.     (unless (eq ok t)
  411.       (return-from legal-qualifiers-p
  412.         (format nil "Contains ~S which ~A" q ok)))))
  413.     t))
  414.  
  415. (defmethod legal-qualifier-p ((object standard-method) x)
  416.   (if (and x (atom x))
  417.       t
  418.       "is not a non-null atom"))
  419.  
  420. (defmethod legal-slot-name-p ((object standard-method) x)
  421.   (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
  422.     ((keywordp x)      "is a keyword and so cannot be bound")
  423.     ((memq x '(t nil)) "cannot be bound")
  424.     (t t)))
  425.  
  426. (defmethod legal-specializers-p ((object standard-method) x)
  427.   (flet ((improper-list ()
  428.        (return-from legal-specializers-p "Is not a proper list.")))
  429.     (dolist-carefully (s x improper-list)
  430.       (let ((ok (legal-specializer-p object s)))
  431.     (unless (eq ok t)
  432.       (return-from legal-specializers-p
  433.         (format nil "Contains ~S which ~A" s ok)))))
  434.     t))
  435.  
  436. (defvar *allow-experimental-specializers-p* nil)
  437.  
  438. (defmethod legal-specializer-p ((object standard-method) x)
  439.   (if (if *allow-experimental-specializers-p*
  440.       (specializerp x)
  441.       (or (classp x)
  442.           (eql-specializer-p x)))
  443.       t
  444.       "is neither a class object nor an eql specializer"))
  445.  
  446. (defmethod shared-initialize :before ((method standard-method)
  447.                       slot-names
  448.                       &key qualifiers
  449.                        lambda-list
  450.                        specializers
  451.                        function
  452.                                            optimized-function
  453.                                            closure-generator
  454.                                            optimized-slot-indices
  455.                                            documentation)
  456.   (declare (ignore slot-names closure-generator optimized-slot-indices
  457.                    documentation))
  458.   (flet ((lose (initarg value string)
  459.        (error "When initializing the method ~S:~%~
  460.                    The ~S initialization argument was: ~S.~%~
  461.                    which ~A."
  462.           method initarg value string)))
  463.     (let ((check-qualifiers    (legal-qualifiers-p method qualifiers))
  464.       (check-lambda-list   (legal-lambda-list-p method lambda-list))
  465.       (check-specializers  (legal-specializers-p method specializers))
  466.       (check-function      (legal-method-function-p method function))
  467.       (check-optimized-function
  468.              (legal-method-function-p method optimized-function)))
  469.       (unless (eq check-qualifiers t)
  470.     (lose :qualifiers qualifiers check-qualifiers))
  471.       (unless (eq check-lambda-list t)
  472.     (lose :lambda-list lambda-list check-lambda-list))
  473.       (unless (eq check-specializers t)
  474.     (lose :specializers specializers check-specializers))
  475.       (unless (eq check-optimized-function t)
  476.     (lose :optimized-function optimized-function check-optimized-function))
  477.       (unless (eq check-function t)
  478.     (lose :function function check-function)))))
  479.  
  480. (defmethod shared-initialize :before ((method standard-accessor-method)
  481.                       slot-names
  482.                       &key
  483.                                       (check-initargs-legality-p T)
  484.                                       slot-name
  485.                                       (slot-definition () slot-def-supplied-p))
  486.   (declare (ignore slot-names))
  487.   (when check-initargs-legality-p
  488.     (let ((legalp (legal-slot-name-p method slot-name)))
  489.       (unless (eq legalp t)
  490.         (error "The value of the :SLOT-NAME initarg ~A." legalp)))
  491.     (when (and slot-def-supplied-p
  492.                (not (*typep slot-definition 'direct-slot-definition)))
  493.       (error "When initializing the accessor method ~S:~%~
  494.               The initialization argument :slot-definition was ~A.~%~
  495.               It must be an instance of a subclass of DIRECT-SLOT-DEFINITION"
  496.              method slot-definition))))
  497.  
  498. (defmethod shared-initialize :after ((method standard-method)
  499.                                      slot-names
  500.                                      &key
  501.                      function
  502.                                      optimized-function
  503.                                      closure-generator
  504.                                      identifier
  505.                                      (qualifiers () qualifiers-p)
  506.                                      (constant-value () constant-value-p))
  507.   (declare (ignore slot-names))
  508.   (when qualifiers-p
  509.     (setf (plist-value method 'qualifiers) qualifiers))
  510.   (when constant-value-p
  511.     (setf (plist-value method 'constant-value) constant-value))
  512.   (when function
  513.     (setf function (method-function-storage-form function))
  514.     (setf (slot-value method 'function) function)
  515.     (setf (method-function-method function) method)
  516.     (pushnew (cons nil function)
  517.              (method-cached-functions-alist method) :test #'equal))
  518.   (when optimized-function
  519.     (setf optimized-function (method-function-storage-form optimized-function))
  520.     (setf (slot-value method 'optimized-function) optimized-function)
  521.     (setf (method-function-method optimized-function) method)
  522.     (pushnew (cons nil optimized-function)
  523.              (method-cached-functions-alist method) :test #'equal))
  524.   (when closure-generator
  525.     (setf (slot-value method 'closure-generator)
  526.           (method-function-storage-form closure-generator)))
  527.   (when identifier
  528.     (setf (get-method-from-identifier identifier) method)))
  529.  
  530. (defmethod method-qualifiers ((method standard-method))
  531.   (plist-value method 'qualifiers))
  532.  
  533. (declaim (ftype (function (T) (values T boolean)) method-constant-value))
  534. (defmethod method-constant-value ((method standard-method))
  535.   "First value returned is constant value returned by method if it does,
  536.    second value is whether or not the method has a constant value."
  537.   (let ((constant-value-or-default
  538.           (plist-value method 'constant-value 'no-constant-value)))
  539.     (if (eq constant-value-or-default 'no-constant-value)
  540.         (values NIL NIL)
  541.         (values constant-value-or-default T))))
  542.  
  543.  
  544.  
  545.  
  546. (defclass generic-function (dependent-update-mixin
  547.                 definition-source-mixin
  548.                 documentation-mixin
  549.                 metaobject)
  550.      ()
  551.   (:metaclass funcallable-standard-class)
  552.   (:predicate-name generic-function-p))
  553.     
  554. (defclass standard-generic-function (generic-function)
  555.      ((name
  556.     :initform nil
  557.     :initarg :name
  558.     :accessor generic-function-name)
  559.       (methods
  560.     :initform ()
  561.     :accessor generic-function-methods)
  562.       (method-class
  563.     :initarg :method-class
  564.     :accessor generic-function-method-class)
  565.       (method-combination
  566.     :initarg :method-combination
  567.     :accessor generic-function-method-combination)
  568.       (lambda-list
  569.     :initarg  :lambda-list
  570.         :reader generic-function-lambda-list)
  571.       (argument-precedence-order
  572.     :initarg  :argument-precedence-order
  573.         :reader generic-function-argument-precedence-order)
  574.       (declarations
  575.         :initform nil
  576.     :initarg  :declarations
  577.         :reader generic-function-declarations)
  578.  
  579. ;     (permutation
  580. ;    :accessor gf-permutation)
  581.       (arg-info
  582.         :initform (make-arg-info)
  583.     :reader gf-arg-info)
  584.       (dfun-state
  585.     :initform ()
  586.     :accessor gf-dfun-state)
  587.       (valid-p
  588.     :initform nil
  589.     :accessor gf-valid-p)
  590.       (pretty-arglist
  591.     :initform ()
  592.     :accessor gf-pretty-arglist)
  593.       )
  594.   (:metaclass funcallable-standard-class)
  595.   (:predicate-name standard-generic-function-p)
  596.   (:default-initargs :method-class *the-class-standard-method*
  597.              :method-combination *standard-method-combination*))
  598.  
  599.  
  600. (defvar *the-class-generic-function*          (find-class 'generic-function))
  601. (defvar *the-class-standard-generic-function* (find-class 'standard-generic-function))
  602.  
  603.  
  604.  
  605. (defmethod store-method-function-p ((generic-function standard-generic-function)
  606.                                     (method           standard-method)
  607.                                     initargs)
  608.   ;; Should methods of this generic-function store their own method-function?
  609.   ;; Answer is normally T to keep stay compatible with the AMOP even
  610.   ;; though PCL actually uses the function in method-optimized-function
  611.   ;; for efficiency.  However, answer can be NIL if the programmer doesn't
  612.   ;; care about method-functions, which will cut down on binary sizes
  613.   ;; significantly since it would stop methods from carrying around
  614.   ;; an extra (unused) method-function.
  615.   (declare (ignore initargs))
  616.   *standard-store-method-function-p*)
  617.  
  618. (defmethod store-method-optimized-function-p
  619.            ((generic-function standard-generic-function)
  620.             (method           standard-method)
  621.             initargs)
  622.   ;; Should methods of this generic-function store their own
  623.   ;; method-optimized-function?
  624.   ;;   Answer better be T unless a closure-generator is stored
  625.   ;; for the method instead, or if the programmer has redefined the
  626.   ;; discriminating method function dispatch code to use the
  627.   ;; documented method-functions rather than the optimized PCL
  628.   ;; method-optimized-functions,
  629.   (null (memq :optimized-slot-indices initargs)))
  630.  
  631. (defmethod store-closure-generator-p
  632.            ((generic-function standard-generic-function)
  633.             (method           standard-method)
  634.             initargs)
  635.   ;; Should methods of this generic-function store their own
  636.   ;; method function closure generators?
  637.   ;;   Answer better be T unless a method-optimized-function is
  638.   ;; stored instead, or if the programmer has redefined the
  639.   ;; the discriminating method function dispatch code to use
  640.   ;; the documented method-functions rather than the optimized
  641.   ;; PCL method-optimized-functions.
  642.   (not (null (memq :optimized-slot-indices initargs))))
  643.  
  644. (defmethod store-optimized-method-lambda-p
  645.            ((generic-function standard-generic-function)
  646.             (method           standard-method)
  647.             initargs)
  648.   ;;   Should methods of this generic-function store their own
  649.   ;; their optimized-method-lambdas?
  650.   ;;   Generally only stored when the method contains slot-value
  651.   ;; accesses on its parameter lists, in which case the lambda
  652.   ;; is used to compile the cached method for slot accesses of non
  653.   ;; :instance allocated slots or non-standard instances at
  654.   ;; runtime to directly optimize those accesses.
  655.   (and *compile-slot-access-method-functions-at-runtime-p*
  656.        (not (null (memq :optimized-slot-indices initargs)))))
  657.  
  658. (declaim (ftype (function (T T T T) (values list list))
  659.                 make-method-lambda
  660.                 make-optimized-method-lambda))
  661.  
  662. (defmethod make-method-lambda ((generic-function standard-generic-function)
  663.                                (method           standard-method)
  664.                                lambda-expression
  665.                                environment)
  666.   (multiple-value-bind (optimized-method-lambda initargs)
  667.       (make-optimized-method-lambda generic-function method
  668.                                     lambda-expression environment)
  669.    ;; Pass the optimized-method-lambda back through a global for
  670.    ;; for macro or accessor expansion.
  671.    (setf *optimized-method-lambda* optimized-method-lambda)
  672.    (values
  673.      (make-documented-standard-method-lambda
  674.         lambda-expression
  675.         environment
  676.         *standard-pcl-make-method-lambda-doc-string*
  677.         (getf initargs :identifier))
  678.      initargs)))
  679.  
  680. (defmethod make-optimized-method-lambda
  681.            ((generic-function standard-generic-function)
  682.             (method           standard-method)
  683.             lambda-expression
  684.             environment)
  685.   (make-optimized-standard-method-lambda generic-function method
  686.                                          lambda-expression environment))
  687.  
  688. (defmethod make-closure-generator-form
  689.            ((generic-function standard-generic-function)
  690.             (method           standard-method)
  691.             optimized-method-lambda
  692.             initargs)
  693.   ;; Closure generators must be in the form of functions whose arguments
  694.   ;; is a list of the wrappers of the objects passed to a generic function
  695.   ;; (or null), and which generates the method-optimized-function cached
  696.   ;; for the generic function when the gf is called with parameters having
  697.   ;; those wrappers.
  698.   (make-std-closure-generator-form
  699.     generic-function method optimized-method-lambda initargs))
  700.  
  701. (defmethod optimize-instance-access ((generic-function standard-generic-function)
  702.                                      (method           standard-method)
  703.                                      (parameter-class  T)
  704.                                      parameter slots read/write slot-name new-value)
  705.   (optimize-std-instance-access parameter-class parameter slots read/write
  706.                                 slot-name new-value))
  707.  
  708. (defmethod optimize-instance-access ((generic-function standard-generic-function)
  709.                                      (method           standard-method)
  710.                                      (parameter-class  structure-class)
  711.                                      parameter slots read/write slot-name new-value)
  712.   (declare (ignore slots))
  713.   (let ((slotd (find-slot-definition parameter-class slot-name)))
  714.     (ecase read/write
  715.       (:read
  716.        `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
  717.       (:write
  718.        `(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)
  719.          ,new-value))
  720.       (:boundp
  721.        'T))))
  722.  
  723. (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
  724.   (declare (ignore direct-slot initargs))
  725.   *the-class-standard-reader-method*)
  726.  
  727. (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
  728.   (declare (ignore direct-slot initargs))
  729.   *the-class-standard-writer-method*)
  730.  
  731. (defmethod boundp-method-class ((class slot-class) direct-slot &rest initargs)
  732.   (declare (ignore direct-slot initargs))
  733.   *the-class-standard-boundp-method*)
  734.  
  735. (defmethod reader-method-class ((class standard-class)
  736.                                 (direct-slot standard-direct-slot-definition)
  737.                                 &rest initargs)
  738.   (declare (ignore initargs))
  739.   *the-class-standard-reader-method*)
  740.  
  741. (defmethod writer-method-class ((class standard-class)
  742.                                 (direct-slot standard-direct-slot-definition)
  743.                                 &rest initargs)
  744.   (declare (ignore initargs))
  745.   *the-class-standard-writer-method*)
  746.  
  747. (defmethod boundp-method-class ((class standard-class)
  748.                                 (direct-slot standard-direct-slot-definition)
  749.                                 &rest initargs)
  750.   (declare (ignore initargs))
  751.   *the-class-standard-boundp-method*)
  752.  
  753.  
  754. (defmethod reader-method-class ((class funcallable-standard-class)
  755.                                 (direct-slot standard-direct-slot-definition)
  756.                                 &rest initargs)
  757.   (declare (ignore initargs))
  758.   *the-class-standard-reader-method*)
  759.  
  760. (defmethod writer-method-class ((class funcallable-standard-class)
  761.                                 (direct-slot standard-direct-slot-definition)
  762.                                 &rest initargs)
  763.   (declare (ignore initargs))
  764.   *the-class-standard-writer-method*)
  765.  
  766. (defmethod boundp-method-class ((class funcallable-standard-class)
  767.                                 (direct-slot standard-direct-slot-definition)
  768.                                 &rest initargs)
  769.   (declare (ignore initargs))
  770.   *the-class-standard-boundp-method*)
  771.  
  772.  
  773. (defmethod print-object ((generic-function generic-function) stream)
  774.   (named-object-print-function
  775.     generic-function
  776.     stream
  777.     (list (length (the list (generic-function-methods generic-function))))))
  778.  
  779.  
  780. (defmethod shared-initialize :before
  781.        ((generic-function standard-generic-function)
  782.         slot-names
  783.         &key (check-initargs-legality-p T)
  784.                  (name nil namep)
  785.          (lambda-list () lambda-list-p)
  786.          argument-precedence-order
  787.          declarations
  788.          documentation
  789.          (method-class nil method-class-supplied-p)
  790.          (method-combination nil method-combination-supplied-p))
  791.  
  792.   (declare (ignore slot-names documentation))
  793.  
  794.   (when namep
  795.     (set-function-name generic-function name))
  796.            
  797.   (flet ((initarg-error (initarg value string)
  798.        (error "When initializing the generic-function ~S:~%~
  799.                    The ~S initialization argument was: ~A.~%~
  800.                    It must be ~A."
  801.           generic-function initarg value string)))
  802.     (cond (method-class-supplied-p
  803.        (when (symbolp method-class)
  804.          (setq method-class (find-class method-class)))
  805.        (unless (and (classp method-class)
  806.             (*subtypep (class-eq-specializer method-class)
  807.                    *the-class-method*))
  808.          (initarg-error :method-class
  809.                 method-class
  810.                 "a subclass of the class METHOD"))
  811.        (setf (slot-value generic-function 'method-class) method-class))
  812.       ((slot-boundp generic-function 'method-class))
  813.       (check-initargs-legality-p
  814.        (initarg-error :method-class
  815.               "not supplied"
  816.               "a subclass of the class METHOD")))
  817.     (cond (method-combination-supplied-p
  818.        (unless (method-combination-p method-combination)
  819.          (initarg-error :method-combination
  820.                 method-combination
  821.                 "a method combination object")))
  822.       ((slot-boundp generic-function 'method-combination))
  823.       (check-initargs-legality-p
  824.        (initarg-error :method-combination
  825.               "not supplied"
  826.               "a method combination object")))
  827.  
  828.     (cond (lambda-list-p
  829.            (unless (legal-lambda-list-p generic-function lambda-list)
  830.              (initarg-error :lambda-list
  831.                             lambda-list
  832.                             "lambda list without default initial value forms"))
  833.            (when argument-precedence-order
  834.              (unless (and (listp argument-precedence-order)
  835.                           (permutation-p argument-precedence-order
  836.                                          (lambda-list-required-args
  837.                                             lambda-list)))
  838.                (initarg-error :argument-precedence-order
  839.                               argument-precedence-order
  840.                               "permutation of required :lambda-list args"))))
  841.            (argument-precedence-order
  842.              (initarg-error :argument-precedence-order
  843.                             argument-precedence-order
  844.                             "supplied only when :lambda-list is supplied")))
  845.     (when (and declarations
  846.                (not (legal-declarations-p generic-function declarations)))
  847.       (initarg-error :declarations
  848.                      declarations
  849.                      "a legal set of DEFGENERIC declarations"))))
  850.  
  851. (defmethod shared-initialize :after
  852.        ((generic-function standard-generic-function)
  853.         slot-names
  854.         &key (lambda-list () lambda-list-p)
  855.          (argument-precedence-order () argument-precedence-order-p))
  856.   (declare (ignore slot-names argument-precedence-order))
  857.   (when (and lambda-list-p (not argument-precedence-order-p))
  858.     (setf (slot-value generic-function 'argument-precedence-order)
  859.           (lambda-list-required-args lambda-list))))
  860.  
  861. (defmethod legal-declarations-p ((object standard-generic-function) x)
  862.   (listp x))
  863.  
  864. (defmethod legal-lambda-list-p ((object standard-generic-function) x)
  865.   (lambda-list-legal-p x NIL (remove '&aux lambda-list-keywords)))
  866.  
  867.  
  868. #||
  869. (defmethod reinitialize-instance ((generic-function standard-generic-function)
  870.                   &rest initargs
  871.                   &key name
  872.                        lambda-list
  873.                        argument-precedence-order
  874.                        declarations
  875.                        documentation
  876.                        method-class
  877.                        method-combination)
  878.   (declare (ignore documentation declarations argument-precedence-order
  879.            lambda-list name method-class method-combination))
  880.   (macrolet ((add-initarg (check name slot-name)
  881.            `(unless ,check
  882.           (push (slot-value generic-function ,slot-name) initargs)
  883.           (push ,name initargs))))
  884. ;   (add-initarg name :name 'name)
  885. ;   (add-initarg lambda-list :lambda-list 'lambda-list)
  886. ;   (add-initarg argument-precedence-order
  887. ;         :argument-precedence-order
  888. ;         'argument-precedence-order)
  889. ;   (add-initarg declarations :declarations 'declarations)
  890. ;   (add-initarg documentation :documentation 'documentation)
  891. ;   (add-initarg method-class :method-class 'method-class)
  892. ;   (add-initarg method-combination :method-combination 'method-combination)
  893.     (apply #'call-next-method generic-function initargs)))
  894. ||#
  895.  
  896.  
  897. ;;;
  898. ;;; These three are scheduled for demolition.
  899. ;;; 
  900. (defmethod remove-named-method (generic-function-name argument-specifiers
  901.                               &optional extra)
  902.   (let ((generic-function ())
  903.     (method ()))
  904.     (cond ((or (null (fboundp generic-function-name))
  905.            (not (generic-function-p
  906.               (setq generic-function
  907.                 (symbol-function generic-function-name)))))
  908.        (error "~S does not name a generic-function."
  909.           generic-function-name))
  910.       ((null (setq method (get-method generic-function
  911.                       extra
  912.                       (parse-specializers
  913.                         argument-specifiers)
  914.                       nil)))
  915.        (error "There is no method for the generic-function ~S~%~
  916.                    which matches the argument-specifiers ~S."
  917.           generic-function
  918.           argument-specifiers))
  919.       (t
  920.        (remove-method generic-function method)))))
  921.  
  922. (defvar *reinitialize-gf-updates-dfun-p* T)
  923.  
  924. (defun real-add-named-method (generic-function-name
  925.                               method-class
  926.                   qualifiers
  927.                   specializers
  928.                   lambda-list
  929.                   function
  930.                   optimized-function
  931.                   closure-generator
  932.                   &rest other-initargs)
  933.   ;; What about changing the class of the generic-function if there is
  934.   ;; one.  Whose job is that anyways.  Do we need something kind of
  935.   ;; like class-for-redefinition?
  936.   (let* ((*reinitialize-gf-updates-dfun-p* NIL)
  937.          (generic-function
  938.        (ensure-generic-function generic-function-name
  939.          :lambda-list (method-ll->generic-function-ll lambda-list)))
  940.      (specs (parse-specializers specializers))
  941.      (new (apply #'make-instance
  942.              method-class
  943.              :qualifiers qualifiers
  944.              :specializers specs
  945.              :lambda-list lambda-list
  946.              :function function
  947.              :function
  948.                        (method-function-storage-form function)
  949.                      :optimized-function
  950.                        (method-function-storage-form optimized-function)
  951.                      :closure-generator
  952.                        (method-function-storage-form closure-generator)
  953.              other-initargs)))
  954.     (add-method generic-function new)))
  955.  
  956.     
  957. (defun make-specializable (function-name &key (arglist nil arglistp))
  958.   (declare (type boolean arglistp))
  959.   (cond ((not (null arglistp)))
  960.     ((not (fboundp function-name)))
  961.     ((fboundp 'function-arglist)
  962.      ;; function-arglist exists, get the arglist from it.
  963.      (setq arglist (function-arglist function-name)))
  964.     (t
  965.      (error
  966.        "The :arglist argument to make-specializable was not supplied~%~
  967.             and there is no version of FUNCTION-ARGLIST defined for this~%~
  968.             port of Portable CommonLoops.~%~
  969.             You must either define a version of FUNCTION-ARGLIST (which~%~
  970.             should be easy), and send it off to the Portable CommonLoops~%~
  971.             people or you should call make-specializable again with the~%~
  972.             :arglist keyword to specify the arglist.")))
  973.   (let ((original (and (fboundp function-name)
  974.                (symbol-function function-name)))
  975.     (generic-function (make-instance 'standard-generic-function
  976.                      :name function-name))
  977.     (nrequireds 0))
  978.     (declare (type index nrequireds))
  979.     (if (generic-function-p original)
  980.     original
  981.     (progn
  982.       (dolist (arg arglist)
  983.         (if (memq arg lambda-list-keywords)
  984.         (return)
  985.         (incf nrequireds)))
  986.       (setf (symbol-function function-name) generic-function)
  987.       (set-function-name generic-function function-name)
  988.       (when arglistp
  989.         (setf (gf-pretty-arglist generic-function) arglist))
  990.       (when original
  991.         (add-named-method
  992.               function-name
  993.               'standard-method
  994.           ()
  995.           (make-list nrequireds :initial-element 't)
  996.           arglist
  997.               (when (call-store-method-function-p
  998.                       generic-function
  999.                       (class-prototype *the-class-standard-method*)
  1000.                       nil)
  1001.                 (make-std-documented-method-function original))
  1002.           original
  1003.               NIL))
  1004.       generic-function))))
  1005.  
  1006.  
  1007.  
  1008. (defun real-get-method (generic-function qualifiers specializers
  1009.                      &optional (errorp t))
  1010.   (let ((hit
  1011.       (dolist (method (generic-function-methods generic-function))
  1012.         (when (and (equal qualifiers (method-qualifiers method))
  1013.                (every #'same-specializer-p specializers
  1014.                   (method-specializers method)))
  1015.           (return method)))))
  1016.     (cond (hit hit)
  1017.       ((null errorp) nil)
  1018.       (t
  1019.        (error "No method on ~S with qualifiers ~:S and specializers ~:S."
  1020.           generic-function qualifiers specializers)))))
  1021.  
  1022.  
  1023. ;;;
  1024. ;;; Compute various information about a generic-function's arglist by looking
  1025. ;;; at the argument lists of the methods.  The hair for trying not to use
  1026. ;;; &rest arguments lives here.
  1027. ;;;  The values returned are:
  1028. ;;;    number-of-required-arguments
  1029. ;;;       the number of required arguments to this generic-function's
  1030. ;;;       discriminating function
  1031. ;;;    &rest-argument-p
  1032. ;;;       whether or not this generic-function's discriminating
  1033. ;;;       function takes an &rest argument.
  1034. ;;;    specialized-argument-positions
  1035. ;;;       a list of the positions of the arguments this generic-function
  1036. ;;;       specializes (e.g. for a classical generic-function this is the
  1037. ;;;       list: (1)).
  1038. ;;;
  1039. (declaim (ftype (function (T) (values index boolean list))
  1040.                 compute-discriminating-function-arglist-info))
  1041. (defmethod compute-discriminating-function-arglist-info
  1042.        ((generic-function standard-generic-function))
  1043.   (declare (values number-of-required-arguments
  1044.                    rest-argument-p
  1045.                    specialized-argument-postions))
  1046.   (let ((number-required nil)
  1047.         (restp nil)
  1048.         (specialized-positions ())
  1049.     (methods (generic-function-methods generic-function)))
  1050.     (declare (type boolean restp) (list specialized-positions methods))
  1051.     (dolist (method methods)
  1052.       (multiple-value-setq (number-required restp specialized-positions)
  1053.         (compute-discriminating-function-arglist-info-internal
  1054.       generic-function method number-required restp specialized-positions)))
  1055.     (values (the index number-required) restp (sort specialized-positions #'<))))
  1056.  
  1057. (declaim (ftype (function (T T T T T) (values index boolean list))
  1058.                 compute-discriminating-function-arglist-info-internal))
  1059. (defun compute-discriminating-function-arglist-info-internal
  1060.        (generic-function method number-of-requireds restp
  1061.     specialized-argument-positions)
  1062.   (declare (ignore generic-function) (type (or null fixnum) number-of-requireds))
  1063.   (let ((requireds 0))
  1064.     (declare (type index requireds))
  1065.     ;; Go through this methods arguments seeing how many are required,
  1066.     ;; and whether there is an &rest argument.
  1067.     (dolist (arg (method-lambda-list method))
  1068.       (cond ((eq arg '&aux) (return))
  1069.             ((memq arg '(&optional &rest &key))
  1070.              (return (setq restp t)))
  1071.         ((memq arg lambda-list-keywords))
  1072.             (t (setf requireds (the index (1+ requireds))))))
  1073.     ;; Now go through this method's type specifiers to see which
  1074.     ;; argument positions are type specified.  Treat T specially
  1075.     ;; in the usual sort of way.  For efficiency don't bother to
  1076.     ;; keep specialized-argument-positions sorted, rather depend
  1077.     ;; on our caller to do that.
  1078.     (iterate ((type-spec (list-elements (method-specializers method)))
  1079.               (pos (interval :from 0)))
  1080.       (unless (eq type-spec *the-class-t*)
  1081.     (pushnew pos specialized-argument-positions)))
  1082.     ;; Finally merge the values for this method into the values
  1083.     ;; for the exisiting methods and return them.  Note that if
  1084.     ;; num-of-requireds is NIL it means this is the first method
  1085.     ;; and we depend on that.
  1086.     (values (the index (if (and number-of-requireds
  1087.                                (< (the index number-of-requireds) requireds))
  1088.                            number-of-requireds
  1089.                            requireds))
  1090.             (or restp
  1091.         (and number-of-requireds
  1092.                      (/= (the index number-of-requireds) requireds)))
  1093.             specialized-argument-positions)))
  1094.  
  1095. (defun make-discriminating-function-arglist (number-required-arguments restp)
  1096.   (nconc (gathering ((args (collecting)))
  1097.            (iterate ((i (interval :from 0 :below number-required-arguments)))
  1098.              (gather (intern (format nil "Discriminating Function Arg ~D" i))
  1099.              args)))
  1100.          (when restp
  1101.                `(&rest ,(intern "Discriminating Function &rest Arg")))))
  1102.  
  1103.  
  1104. ;;;
  1105. ;;;
  1106. ;;;
  1107. (defstruct (arg-info
  1108.          (:conc-name nil)
  1109.          (:constructor make-arg-info ()))
  1110.   arg-info-precedence
  1111.   arg-info-metatypes
  1112.   (arg-info-number-optional nil :type (or index null))
  1113.   (arg-info-key/rest-p nil :type boolean)
  1114.   arg-info-keywords ;nil         no keyword or rest allowed
  1115.                 ;(k1 k2 ..)  each method must accept these keyword arguments
  1116.                 ;T           must have &key or &rest
  1117.  
  1118.   gf-info-simple-accessor-type ; nil, reader, writer, boundp
  1119.   (gf-precompute-dfun-and-emf-p nil :type boolean) ; set by set-arg-info
  1120.  
  1121.   gf-info-static-c-a-m-emf
  1122.   (gf-info-c-a-m-emf-std-p nil :type boolean)
  1123.   (arg-info-lambda-list :no-lambda-list))
  1124.  
  1125. (declaim (ftype (function (T) boolean) arg-info-valid-p))
  1126. (defun arg-info-valid-p (arg-info)
  1127.   (not (null (arg-info-number-optional arg-info))))
  1128.  
  1129. (declaim (ftype (function (T) boolean) arg-info-applyp))
  1130. (defun arg-info-applyp (arg-info)
  1131.   (or (plusp (the index (arg-info-number-optional arg-info)))
  1132.       (arg-info-key/rest-p arg-info)))
  1133.  
  1134. (declaim (ftype (function (T) index) arg-info-number-required))
  1135. (defun arg-info-number-required (arg-info)
  1136.   (length (the list (arg-info-metatypes arg-info))))
  1137.  
  1138. (declaim (ftype (function (T) index) arg-info-nkeys))
  1139. (defun arg-info-nkeys (arg-info)
  1140.   (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
  1141.  
  1142. (defun set-arg-info (gf precedence metatypes number-optional key/rest-p keywords
  1143.             &optional (lambda-list nil lambda-list-p))
  1144.   (declare (type index number-optional)
  1145.            (type boolean key/rest-p lambda-list-p))
  1146.   (let ((arg-info (gf-arg-info gf)))
  1147.     (setf (arg-info-precedence arg-info) precedence)
  1148.     (setf (arg-info-metatypes arg-info) metatypes)
  1149.     (setf (arg-info-number-optional arg-info) number-optional)
  1150.     (setf (arg-info-key/rest-p arg-info) key/rest-p)
  1151.     (setf (arg-info-keywords arg-info) keywords)
  1152.     (when lambda-list-p
  1153.       (setf (arg-info-lambda-list arg-info) lambda-list))
  1154.     (setf (gf-precompute-dfun-and-emf-p arg-info)
  1155.           (the boolean
  1156.            (let* ((name (generic-function-name gf))
  1157.               (sym (if (atom name) name (cadr name)))
  1158.               (pkg-list (cons *the-pcl-package* 
  1159.                       (package-use-list *the-pcl-package*))))
  1160.              (not (null (memq (symbol-package sym) pkg-list))))))
  1161.     arg-info))
  1162.  
  1163. (defun new-arg-info-from-generic-function (gf lambda-list argument-precedence-order)
  1164.   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
  1165.       (analyze-lambda-list lambda-list)
  1166.     (declare (type index   nreq nopt)
  1167.              (type boolean keysp restp)
  1168.              (type list    keywords)
  1169.              (ignore allow-other-keys-p))
  1170.     (let ((metatypes (make-list nreq))
  1171.       (precedence
  1172.             (compute-precedence lambda-list nreq argument-precedence-order)))
  1173.       (set-arg-info gf
  1174.             precedence
  1175.             metatypes
  1176.             nopt
  1177.             (or keysp restp)
  1178.             keywords
  1179.             lambda-list))))
  1180.  
  1181. (defun new-arg-info-from-method (gf method)
  1182.   (multiple-value-bind (nreq nopt keysp restp)
  1183.       (analyze-lambda-list (method-lambda-list method))
  1184.     (declare (type index   nreq nopt)
  1185.              (type boolean keysp restp))
  1186.     (set-arg-info gf
  1187.           (compute-precedence (method-lambda-list method) nreq ())
  1188.           (mapcar #'raise-metatype 
  1189.               (make-list nreq) (method-specializers method))
  1190.           nopt
  1191.           (or keysp restp)
  1192.           ())))
  1193.  
  1194. (defun add-arg-info (generic-function method)
  1195.   (let ((arg-info (gf-arg-info generic-function)))
  1196.     (if (not (arg-info-valid-p arg-info))
  1197.     (new-arg-info-from-method generic-function method)
  1198.     (flet ((lose (string &rest args)
  1199.          (error "Attempt to add the method ~S to the generic function ~S.~%~
  1200.                    But ~A"
  1201.             method
  1202.             generic-function
  1203.             (apply #'format nil string args)))
  1204.            (compare (x y)
  1205.          (declare (type index x y))
  1206.          (if (> x y) "more" "fewer")))
  1207.       (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
  1208.           (analyze-lambda-list (method-lambda-list method))
  1209.             (declare (type index   nreq nopt)
  1210.                      (type boolean keysp restp allow-other-keys-p)
  1211.                      (type list    keywords))
  1212.         (let ((gf-nreq (arg-info-number-required arg-info))
  1213.           (gf-nopt (arg-info-number-optional arg-info))
  1214.           (gf-key/rest-p (arg-info-key/rest-p arg-info))
  1215.           (gf-keywords (arg-info-keywords arg-info)))
  1216.               (declare (type index   gf-nreq gf-nopt)
  1217.                    (type boolean gf-key/rest-p))
  1218.  
  1219.           (unless (= nreq gf-nreq)
  1220.         (lose "the method has ~A required arguments than the generic function."
  1221.               (compare nreq gf-nreq)))
  1222.           (unless (= nopt gf-nopt)
  1223.         (lose "the method has ~S optional arguments than the generic function."
  1224.               (compare nopt gf-nopt)))
  1225.           (unless (eq (or keysp restp) gf-key/rest-p)
  1226.         (error "the method and generic function differ in whether they accept~%~
  1227.                   rest or keyword arguments."))
  1228.           (when gf-keywords
  1229.         (unless (or (and restp (not keysp))
  1230.                 allow-other-keys-p
  1231.                 (every #'(lambda (k) (memq k keywords)) gf-keywords))
  1232.           (error
  1233.            "the generic function requires each method to accept the keyword arguments~%~
  1234.                ~S.  The method does not accept all of these."
  1235.            gf-keywords)))
  1236.           (set-arg-info generic-function
  1237.                 (arg-info-precedence arg-info)
  1238.                 (mapcar #'raise-metatype (arg-info-metatypes arg-info)
  1239.                     (method-specializers method))
  1240.                 gf-nopt
  1241.                 gf-key/rest-p
  1242.                 gf-keywords)))))))
  1243.  
  1244. (defun remove-arg-info (generic-function method)
  1245.   (let ((arg-info (gf-arg-info generic-function)))
  1246.     (set-arg-info generic-function
  1247.           (arg-info-precedence arg-info)
  1248.           (let* ((nreq (arg-info-number-required arg-info))
  1249.              (metatypes (make-list nreq))
  1250.              (old-methods (generic-function-methods generic-function))
  1251.              (methods (remove method old-methods)))
  1252.             (declare (type index nreq))
  1253.             (dolist (specls (mapcar #'method-specializers methods))
  1254.               (setq metatypes (mapcar #'raise-metatype metatypes specls)))
  1255.             metatypes)
  1256.           (arg-info-number-optional arg-info)
  1257.           (arg-info-key/rest-p arg-info)
  1258.           (arg-info-keywords arg-info))))
  1259.  
  1260. (defmethod initialize-instance :after ((gf standard-generic-function)
  1261.                        &key (lambda-list nil lambda-list-p)
  1262.                        argument-precedence-order)
  1263.   (when lambda-list-p
  1264.     (new-arg-info-from-generic-function gf lambda-list argument-precedence-order))
  1265.   (when (arg-info-valid-p (gf-arg-info gf))
  1266.     (update-dfun gf)))
  1267.  
  1268. (defmethod reinitialize-instance :after ((gf standard-generic-function)
  1269.                      &rest args
  1270.                      &key (lambda-list nil lambda-list-p)
  1271.                      argument-precedence-order)
  1272.   (let* ((arg-info (gf-arg-info gf))
  1273.      (valid-p (arg-info-valid-p arg-info)))
  1274.     (when lambda-list-p
  1275.       (if (not valid-p)
  1276.       (new-arg-info-from-generic-function gf lambda-list argument-precedence-order)
  1277.       (setf (arg-info-lambda-list arg-info) lambda-list)))
  1278.     (when (and *reinitialize-gf-updates-dfun-p*
  1279.                valid-p args
  1280.            (or (not (eq (car args) 'lambda-list))
  1281.            (cddr args)))
  1282.       (update-dfun gf))))
  1283.  
  1284. ;;;
  1285. ;;;
  1286. ;;;
  1287. (defun compute-precedence (lambda-list nreq argument-precedence-order)
  1288.   (declare (type list lambda-list argument-precedence-order))
  1289.   (declare (ignore nreq))
  1290.   (let ((nreq (analyze-lambda-list lambda-list)))
  1291.     (declare (type index nreq))
  1292.     (if (null argument-precedence-order)
  1293.     (let ((list nil))(dotimes (i nreq list) (push (- (1- nreq) i) list)))
  1294.     (mapcar #'(lambda (x) (position x lambda-list)) argument-precedence-order))))
  1295.  
  1296.  
  1297. (defmethod no-applicable-method (generic-function &rest args)
  1298.   (cerror "Retry call to ~S"
  1299.       "No matching method for the generic-function ~S,~@
  1300.           when called with arguments ~S."
  1301.       generic-function args)
  1302.   (apply generic-function args))
  1303.  
  1304. (defmethod no-next-method ((generic-function standard-generic-function)
  1305.                            (method standard-method)
  1306.                            &rest args)
  1307.   (error
  1308.     "No next method for generic function ~S in method ~S"
  1309.     generic-function method args))
  1310.  
  1311. (proclaim '(special *lazy-dfun-compute-p*))
  1312.  
  1313. (defun real-add-method (generic-function method)
  1314.   (if (method-generic-function method)
  1315.       (error "The method ~S is already part of the generic~@
  1316.               function ~S.  It can't be added to another generic~@
  1317.               function until it is removed from the first one."
  1318.          method (method-generic-function method))
  1319.  
  1320.       (let* ((name (generic-function-name generic-function))
  1321.          (qualifiers   (method-qualifiers method))
  1322.          (lambda-list  (method-lambda-list method))
  1323.          (specializers (method-specializers method))
  1324.          (existing (get-method generic-function qualifiers specializers nil)))
  1325.     ;;
  1326.     ;; If there is already a method like this one then we must
  1327.     ;; get rid of it before proceeding.  Note that we call the
  1328.     ;; generic function remove-method to remove it rather than
  1329.     ;; doing it in some internal way.
  1330.     ;; 
  1331.     (when existing (remove-method generic-function existing))
  1332.     ;;
  1333.     (setf (method-generic-function method) generic-function)
  1334.     (setf (method-function-name method)
  1335.           (intern-function-name
  1336.            (make-method-spec name
  1337.                  qualifiers
  1338.                  (unparse-specializers specializers))))
  1339.         (unless (slot-boundp generic-function 'lambda-list)
  1340.           (let ((gf-lambda-list
  1341.                   (method-ll->generic-function-ll lambda-list)))
  1342.             (fast-set-slot-value generic-function 'lambda-list gf-lambda-list
  1343.                                  slow-slot-value)
  1344.             (fast-set-slot-value generic-function 'argument-precedence-order
  1345.                                  (lambda-list-required-args gf-lambda-list)
  1346.                                  slow-slot-value)))
  1347.     (add-arg-info generic-function method)
  1348.     (pushnew method (generic-function-methods generic-function))
  1349.     (dolist (specializer specializers)
  1350.       (add-direct-method specializer method))
  1351.     (update-gf-info generic-function)
  1352.     (update-dfun generic-function)
  1353.     (maybe-update-constructors generic-function method)
  1354.     method)))
  1355.  
  1356. (defun real-remove-method (generic-function method)
  1357.   (if  (neq generic-function (method-generic-function method))
  1358.        (error "The method ~S is attached to the generic function~@
  1359.                ~S.  It can't be removed from the generic function~@
  1360.                to which it is not attached."
  1361.           method (method-generic-function method))
  1362.        (let* ((methods      (generic-function-methods generic-function))
  1363.           (new-methods  (remove method methods)))          
  1364.      (setf (method-generic-function method) nil)
  1365.      (setf (generic-function-methods generic-function) new-methods)
  1366.      (dolist (specializer (method-specializers method))
  1367.        (remove-direct-method specializer method))
  1368.      (remove-arg-info generic-function method)
  1369.      (update-dfun generic-function)
  1370.      (maybe-update-constructors generic-function method)
  1371.      generic-function)))
  1372.  
  1373. ;;;
  1374. ;;;
  1375. ;;;
  1376.  
  1377. (declaim (ftype (function (T T) (values boolean boolean))
  1378.                 specializer-applicable-using-type-p))
  1379.  
  1380. (defun compute-applicable-methods-function (generic-function arguments)
  1381.   (values (compute-applicable-methods-using-types 
  1382.        generic-function
  1383.        (types-from-arguments generic-function arguments 'eql))))
  1384.  
  1385. (defmethod compute-applicable-methods 
  1386.     ((generic-function generic-function) arguments)
  1387.   (values (compute-applicable-methods-using-types 
  1388.        generic-function
  1389.        (types-from-arguments generic-function arguments 'eql))))
  1390.  
  1391. (declaim (ftype (function (T T) (values T boolean))
  1392.                 compute-applicable-methods-using-classes))
  1393. (defmethod compute-applicable-methods-using-classes 
  1394.     ((generic-function generic-function) classes)
  1395.   (compute-applicable-methods-using-types 
  1396.    generic-function
  1397.    (types-from-arguments generic-function classes 'class-eq)))
  1398.  
  1399. (declaim (ftype (function (T T) (values list boolean))
  1400.                 compute-applicable-methods-using-types))
  1401. (defun compute-applicable-methods-using-types (generic-function types)
  1402.   (let ((definite-p t) (possibly-applicable-methods nil))
  1403.     (declare (type boolean definite-p))
  1404.     (dolist (method (generic-function-methods generic-function))
  1405.       (let ((specls (method-specializers method))
  1406.         (types types)
  1407.         (possibly-applicable-p t) (applicable-p t))
  1408.         (declare (type boolean possibly-applicable-p applicable-p))
  1409.     (dolist (specl specls)
  1410.       (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
  1411.           (specializer-applicable-using-type-p specl (pop types))
  1412.             (declare (type boolean specl-applicable-p
  1413.                                    specl-possibly-applicable-p))
  1414.         (unless specl-applicable-p
  1415.           (setq applicable-p nil))
  1416.         (unless specl-possibly-applicable-p
  1417.           (setq possibly-applicable-p nil)
  1418.           (return nil))))
  1419.     (when possibly-applicable-p
  1420.       (unless applicable-p (setq definite-p nil))
  1421.       (push method possibly-applicable-methods))))
  1422.     (values (sort-applicable-methods generic-function
  1423.                      (nreverse possibly-applicable-methods)
  1424.                      types)
  1425.         definite-p)))
  1426.  
  1427. ;This is used to speed up precompute-effective-methods.
  1428. (defvar *in-precompute-effective-methods-p* nil)
  1429.  
  1430. ;used only in specializer-applicable-using-type-p
  1431. (declaim (ftype (function (T T) (values boolean boolean))
  1432.                 class-applicable-using-class-p))
  1433. (defun class-applicable-using-class-p (specl type)
  1434.   (let ((pred (class-on-class-precedence-list-p specl type)))
  1435.     (declare (type boolean pred))
  1436.     (values pred
  1437.         (or pred
  1438.         (if (not *in-precompute-effective-methods-p*)
  1439.             ;; classes might get common subclass
  1440.             (superclasses-compatible-p specl type)
  1441.             ;; worry only about existing classes
  1442.             (classes-have-common-subclass-p specl type))))))
  1443.  
  1444. ;used only in map-all-orders
  1445. (declaim (ftype (function (T T) boolean) class-might-precede-p))
  1446. (defun class-might-precede-p (class1 class2)
  1447.   (if (not *in-precompute-effective-methods-p*)
  1448.       (not (or (eq class1 class2)
  1449.                (class-on-class-precedence-list-p class1 class2)))
  1450.       (class-can-precede-p class1 class2)))
  1451.  
  1452. (declaim (ftype (function (T T) (values boolean boolean)) saut-and-p))
  1453. (defun saut-and-p (specl type)
  1454.   (let ((applicable-p nil)
  1455.         (all-solid-p T))
  1456.     (declare (type boolean applicable-p all-solid-p))
  1457.     (dolist (type (cdr type))
  1458.       (multiple-value-bind (appl poss-appl)
  1459.       (specializer-applicable-using-type-p specl type)
  1460.         (declare (type boolean appl poss-appl))
  1461.     (when appl (return (setq applicable-p t)))
  1462.     (unless poss-appl (setq all-solid-p nil))))
  1463.     (values applicable-p (or applicable-p all-solid-p))))
  1464.  
  1465. (declaim (ftype (function (T T) (values boolean boolean)) saut-or-p))
  1466. (defun saut-or-p (specl type)
  1467.   ;; T T if all are definitely applicable.
  1468.   ;; If any are definitely unapplicable, then definitely unapplicable.
  1469.   ;; Else NIL NIL.
  1470.   (let ((any-unapplicable-p NIL)
  1471.         (definitely-unapplicable-p NIL))
  1472.     (declare (type boolean any-unapplicable-p definitely-unapplicable-p))
  1473.     (dolist (type (cdr type))
  1474.       (multiple-value-bind (appl poss-appl)
  1475.       (specializer-applicable-using-type-p specl type)
  1476.         (declare (type boolean appl poss-appl))
  1477.     (unless appl
  1478.           (setq any-unapplicable-p t)
  1479.           (when poss-appl
  1480.             (return (setq definitely-unapplicable-p T))))))
  1481.     (values (not any-unapplicable-p)
  1482.             (or (not any-unapplicable-p) definitely-unapplicable-p))))
  1483.  
  1484. (declaim (ftype (function (T T) (values boolean boolean)) saut-not-p))
  1485. (defun saut-not-p (specl type)
  1486.   (let ((ntype (cadr type)))
  1487.     (values nil
  1488.             (the boolean
  1489.              (case (car ntype)
  1490.                (class      (saut-not-class-p specl ntype))
  1491.                (class-eq   (saut-not-class-eq-p specl ntype))
  1492.                (eql        (saut-not-eql-p specl ntype))
  1493.                (t (error "~s cannot handle the second argument ~s"
  1494.                  'specializer-applicable-using-type-p type)))))))
  1495.  
  1496. (declaim (ftype (function (T T) boolean) saut-not-class-p))
  1497. (defun saut-not-class-p (specl ntype)
  1498.   (not (class-on-class-precedence-list-p (cadr ntype) (type-class specl))))
  1499.  
  1500. (declaim (ftype (function (T T) boolean) saut-not-class-eq-p))
  1501. (defun saut-not-class-eq-p (specl ntype)
  1502.   (let ((class (case (car specl)
  1503.          (eql      (class-of (cadr specl)))
  1504.          (class-eq (cadr specl)))))
  1505.     (not (eq class (cadr ntype)))))
  1506.  
  1507. (declaim (ftype (function (T T) boolean) saut-not-class-eql-p))
  1508. (defun saut-not-eql-p (specl ntype)
  1509.   (case (car specl)
  1510.     (eql (not (eql (cadr specl) (cadr ntype))))
  1511.     (t   t)))
  1512.  
  1513. (declaim (ftype (function (T T) (values boolean boolean)) saut-class-p))
  1514. (defun saut-class-p (specl type)
  1515.   (case (car specl)
  1516.     (class (class-applicable-using-class-p (cadr specl) (cadr type)))
  1517.     (t (values
  1518.           nil
  1519.           (class-on-class-precedence-list-p (cadr type) (type-class specl))))))
  1520.  
  1521. (declaim (ftype (function (T T) (values boolean boolean)) saut-eq-p))
  1522. (defun saut-class-eq-p (specl type)
  1523.   (if (eq (car specl) 'eql)
  1524.       (values nil (eq (class-of (cadr specl)) (cadr type)))
  1525.       (let ((pred (case (car specl)
  1526.             (class-eq (eq (cadr specl) (cadr type)))
  1527.             (class    (or (eq (cadr specl) (cadr type))
  1528.                                   (class-on-class-precedence-list-p
  1529.                         (cadr specl) (cadr type)))))))
  1530.         (declare (type boolean pred))
  1531.     (values pred pred))))
  1532.  
  1533. (declaim (ftype (function (T T) (values boolean boolean)) saut-eql-p))
  1534. (defun saut-eql-p (specl type) 
  1535.   (let ((pred
  1536.           (case (car specl)
  1537.         (eql      (eql (cadr specl) (cadr type)))
  1538.         (class-eq (eq (cadr specl) (class-of (cadr type))))
  1539.             (class    (class-on-class-precedence-list-p
  1540.                     (cadr specl) (class-of (cadr type)))))))
  1541.     (declare (type boolean pred))
  1542.     (values pred pred)))
  1543.  
  1544. (defun specializer-applicable-using-type-p (specl type)
  1545.   (declare (values applicable-p maybe-applicable-p))
  1546.   (setq specl (type-from-specializer specl))
  1547.   (when (eq specl 't)
  1548.     (return-from specializer-applicable-using-type-p (values t t)))
  1549.   ;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
  1550.   ;; and has only what they need.
  1551.   ;;   If it can't handle it, then it gives up and hopes the normal
  1552.   ;; subtypep can figure it out.
  1553.   (if (or (atom type) (eq (car type) 't))
  1554.       (values nil t)
  1555.       (case (car type)
  1556.     (and        (saut-and-p specl type))
  1557.     (or         (saut-or-p specl type))
  1558.     (not        (saut-not-p specl type))
  1559.     (class      (saut-class-p specl type))
  1560.     (class-eq   (saut-class-eq-p specl type))
  1561.     (eql        (saut-eql-p specl type))
  1562.         (t          (multiple-value-bind (appl certain-p)
  1563.                         (subtypep (convert-to-system-type type)
  1564.                                   (convert-to-system-type specl))
  1565.                       (declare (type boolean appl certain-p))
  1566.                       (values appl (or appl (not certain-p))))))))
  1567.  
  1568. (defun proclaim-incompatible-superclasses (classes)
  1569.   (setq classes (mapcar #'(lambda (class)
  1570.                 (if (symbolp class)
  1571.                 (find-class class)
  1572.                 class))
  1573.             classes))
  1574.   (dolist (class classes)
  1575.     (dolist (other-class classes)
  1576.       (unless (eq class other-class)
  1577.     (pushnew other-class (class-incompatible-superclass-list class))))))
  1578.  
  1579. (declaim (ftype (function (T T) boolean) superclasses-compatible-p))
  1580. (defun superclasses-compatible-p (class1 class2)
  1581.   (assure-finalized class1)
  1582.   (assure-finalized class2)
  1583.   (let ((cpl1 (class-precedence-list class1))
  1584.     (cpl2 (class-precedence-list class2)))
  1585.     (dolist (sc1 cpl1 t)
  1586.       (dolist (ic (class-incompatible-superclass-list sc1))
  1587.     (when (memq ic cpl2)
  1588.       (return-from superclasses-compatible-p nil))))))
  1589.  
  1590. (mapc
  1591.  #'proclaim-incompatible-superclasses
  1592.  '(;; superclass class
  1593.    (built-in-class std-class structure-class) ; direct subclasses of pcl-class
  1594.    (standard-class funcallable-standard-class)
  1595.    ;; superclass metaobject
  1596.    (class eql-specializer class-eq-specializer method ; method-combination
  1597.     generic-function slot-definition)
  1598.    ;; metaclass built-in-class
  1599.    (number sequence character        ; direct subclasses of t, but not array
  1600.     standard-object structure-object)
  1601.    (number array character symbol    ; direct subclasses of t, but not sequence
  1602.     standard-object structure-object)
  1603.    (complex float rational)        ; direct subclasses of number
  1604.    (integer ratio)            ; direct subclasses of rational
  1605.    (list vector)            ; direct subclasses of sequence
  1606.    (cons null)                ; direct subclasses of list
  1607.    (string bit-vector)            ; direct subclasses of vector
  1608.    ))
  1609.  
  1610. (declaim (ftype (function (T T) boolean) classes-have-common-subclass-p))
  1611. (defun classes-have-common-subclass-p (class1 class2)
  1612.   (or (eq class1 class2)
  1613.       (let ((class1-subs (class-direct-subclasses class1)))
  1614.     (or (not (null (memq class2 class1-subs)))
  1615.         (dolist (class1-sub class1-subs nil)
  1616.           (when (classes-have-common-subclass-p class1-sub class2)
  1617.         (return t)))))))
  1618.  
  1619. (defun order-specializers (specl1 specl2 index compare-classes-function)
  1620.   (declare (type real-function compare-classes-function))
  1621.   (let ((type1 (specializer-type specl1))
  1622.     (type2 (specializer-type specl2)))
  1623.     (cond ((eq specl1 specl2)
  1624.        nil)
  1625.       ((atom type1)
  1626.        specl2)
  1627.       ((atom type2)
  1628.        specl1)
  1629.       (t
  1630.        (case (car type1)
  1631.          (class    (case (car type2)
  1632.              (class (funcall compare-classes-function specl1 specl2 index))
  1633.              (t specl2)))
  1634.          (class-eq (case (car type2)
  1635.              (eql specl2)
  1636.              (class-eq nil)
  1637.              (class type1)))
  1638.          (eql      (case (car type2)
  1639.              (eql nil)
  1640.              (t specl1))))))))
  1641.  
  1642. (defun sort-applicable-methods (generic-function methods types)
  1643.   (sort-methods methods
  1644.         (arg-info-precedence (gf-arg-info generic-function))
  1645.         #'(lambda (class1 class2 index)
  1646.                     (declare (type index index))
  1647.             (let* ((class (type-class (nth index types)))
  1648.                (cpl (class-precedence-list class)))
  1649.               (if (memq class2 (memq class1 cpl))
  1650.               class1 class2)))))
  1651.  
  1652. (defun sort-methods (methods precedence compare-classes-function)
  1653.   (flet ((sorter (method1 method2)
  1654.        (dolist (index precedence)
  1655.              (declare (type index index))
  1656.          (let* ((specl1 (nth index (method-specializers method1)))
  1657.             (specl2 (nth index (method-specializers method2)))
  1658.             (order (order-specializers 
  1659.                  specl1 specl2 index compare-classes-function)))
  1660.            (when order
  1661.          (return (eq order specl1)))))))
  1662.     (stable-sort methods #'sorter)))
  1663.  
  1664. (defun map-all-orders (methods precedence function)
  1665.   (declare (type real-function function))
  1666.   (let ((choices nil))
  1667.     (flet ((compare-classes-function (class1 class2 index)
  1668.          (declare (ignore index))
  1669.          (let ((choice nil))
  1670.            (dolist (c choices nil)
  1671.          (when (or (and (eq (first c) class1)
  1672.                 (eq (second c) class2))
  1673.                (and (eq (first c) class2)
  1674.                 (eq (second c) class1)))
  1675.            (return (setq choice c))))
  1676.            (unless choice
  1677.          (setq choice
  1678.                (if (class-might-precede-p class1 class2)
  1679.                (if (class-might-precede-p class2 class1)
  1680.                    (list class1 class2 nil t)
  1681.                    (list class1 class2 t))
  1682.                (if (class-might-precede-p class2 class1)
  1683.                    (list class2 class1 t)
  1684.                    (let ((name1 (class-name class1))
  1685.                      (name2 (class-name class2)))
  1686.                  (if (and name1 name2 (symbolp name1) (symbolp name2)
  1687.                       (string< (symbol-name name1)
  1688.                            (symbol-name name2)))
  1689.                      (list class1 class2 t)
  1690.                      (list class2 class1 t))))))
  1691.          (push choice choices))
  1692.            (car choice))))
  1693.       (loop (funcall function
  1694.              (sort-methods methods precedence #'compare-classes-function))
  1695.         (unless (dolist (c choices nil)
  1696.               (unless (third c)
  1697.             (rotatef (car c) (cadr c))
  1698.             (return (setf (third c) t))))
  1699.           (return nil))))))
  1700.  
  1701.  
  1702.  
  1703. (defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
  1704.   nil)
  1705.  
  1706. (defmethod same-specializer-p ((specl1 class) (specl2 class))
  1707.   (eq specl1 specl2))
  1708.  
  1709. (defmethod specializer-class ((specializer class))
  1710.   specializer)
  1711.  
  1712. (defmethod same-specializer-p ((specl1 class-eq-specializer)
  1713.                    (specl2 class-eq-specializer))
  1714.   (eq (specializer-class specl1) (specializer-class specl2)))
  1715.  
  1716. (defmethod same-specializer-p ((specl1 eql-specializer)
  1717.                    (specl2 eql-specializer))
  1718.   (eq (specializer-object specl1) (specializer-object specl2)))
  1719.  
  1720. (defmethod specializer-class ((specializer eql-specializer))
  1721.   (class-of (slot-value specializer 'object)))
  1722.  
  1723.  
  1724.  
  1725.  
  1726. (defvar *in-gf-arg-info-p* nil)
  1727. (defvar arg-info-reader (make-std-reader-method-function 'arg-info))
  1728.  
  1729. (defun types-from-arguments (generic-function arguments &optional type-modifier)
  1730.   (let* ((arg-info (if *in-gf-arg-info-p*
  1731.                (method-function-funcall arg-info-reader generic-function)
  1732.                (let ((*in-gf-arg-info-p* t))
  1733.              (gf-arg-info generic-function))))
  1734.      (metatypes (arg-info-metatypes arg-info))
  1735.      (types-rev nil))
  1736.     (declare (type list metatypes))
  1737.     (dolist (mt metatypes)
  1738.       #-(or excl kcl)
  1739.       (declare (ignore mt))
  1740.       (unless arguments
  1741.     (error "The function ~S requires at least ~D arguments"
  1742.            (generic-function-name generic-function)
  1743.            (length metatypes)))
  1744.       (let ((arg (pop arguments)))
  1745.     (push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
  1746.     (values (nreverse types-rev) arg-info)))
  1747.  
  1748. (defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
  1749.   (declare (type index nkeys))
  1750.   (let* ((w wrappers) (w-tail w) (mt-tail metatypes))
  1751.     (dolist (class (if (listp classes) classes (list classes)))
  1752.       (unless (eq 't (car mt-tail))
  1753.     (let ((c-w (class-wrapper class)))
  1754.           (unless c-w (return-from get-wrappers-from-classes nil))
  1755.       (if (= nkeys 1)
  1756.           (setq w c-w)
  1757.           (setf (car w-tail) c-w
  1758.             w-tail (cdr w-tail)))))
  1759.       (setq mt-tail (cdr mt-tail)))
  1760.     w))
  1761.  
  1762. (declaim (ftype (function (T T T) (values T T)) accessor-values))
  1763. (defun accessor-values (arg-info classes methods)
  1764.   (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
  1765.      (accessor-class (case accessor-type
  1766.                (reader (car classes))
  1767.                (writer (cadr classes))
  1768.                (boundp (car classes))))
  1769.      (slot-name (and accessor-class
  1770.                          (class-standard-p accessor-class)
  1771.              (accessor-method-slot-name (car methods))))
  1772.      (slotd (and accessor-class
  1773.              (find-slot-definition accessor-class slot-name))))
  1774.     (if (and slotd (slot-accessor-std-p slotd accessor-type))
  1775.         (values accessor-type (slot-definition-location slotd))
  1776.         (values nil nil))))
  1777.  
  1778.  
  1779. ;;;
  1780. ;;; Given a generic function and a set of arguments to that generic function,
  1781. ;;; returns a mess of values.
  1782. ;;;
  1783. ;;;  <function>   The compiled effective method function for this set of
  1784. ;;;               arguments. 
  1785. ;;;
  1786. ;;;  <applicable> Sorted list of applicable methods. 
  1787. ;;;
  1788. ;;;  <wrappers>   Is a single wrapper if the generic function has only
  1789. ;;;               one key, that is arg-info-nkeys of the arg-info is 1.
  1790. ;;;               Otherwise a list of the wrappers of the specialized
  1791. ;;;               arguments to the generic function.
  1792. ;;;
  1793. ;;;               Note that all these wrappers are valid.  This function
  1794. ;;;               does invalid wrapper traps when it finds an invalid
  1795. ;;;               wrapper and then returns the new, valid wrapper.
  1796. ;;;
  1797. ;;;  <invalidp>   True if any of the specialized arguments had an invalid
  1798. ;;;               wrapper, false otherwise.
  1799. ;;;
  1800. ;;;  <type>       READER or WRITER when the only method that would be run
  1801. ;;;               is a standard reader or writer method.  To be specific,
  1802. ;;;               the value is READER when the method combination is eq to
  1803. ;;;               *standard-method-combination*; there are no applicable
  1804. ;;;               :before, :after or :around methods; and the most specific
  1805. ;;;               primary method is a standard reader method.
  1806. ;;;
  1807. ;;;  <index>      If <type> is READER or WRITER, and the slot accessed is
  1808. ;;;               an :instance slot, this is the index number of that slot
  1809. ;;;               in the object argument.
  1810. ;;;
  1811.  
  1812. (declaim (ftype (function (T T T)
  1813.                           (values T boolean T T T T))
  1814.                 cache-miss-values))
  1815. (defun cache-miss-values (gf args state)
  1816.   (let* ((arg-info (method-function-funcall arg-info-reader gf))
  1817.      (metatypes (arg-info-metatypes arg-info))
  1818.      (for-accessor-p (eq state 'accessor))
  1819.      (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
  1820.      (cam-std-p (gf-info-c-a-m-emf-std-p arg-info))
  1821.      (args-tail args) (invalid-wrapper-p nil)
  1822.      (wrappers-rev nil) (dfun-wrappers-rev nil)
  1823.      (types-rev nil) (classes-rev nil))
  1824.     (declare (type list    metatypes)
  1825.              (type boolean for-accessor-p for-cache-p cam-std-p
  1826.                            invalid-wrapper-p))
  1827.     (dolist (mt metatypes)
  1828.       (unless args-tail
  1829.     (error "The function ~S requires at least ~D arguments"
  1830.            (generic-function-name gf) (length metatypes)))
  1831.       (let ((arg (pop args-tail)))
  1832.     (multiple-value-bind (wrapper class type)
  1833.         (if (eq mt 't)
  1834.         (values nil *the-class-t* 't)
  1835.         (let ((wrapper (wrapper-of arg)))
  1836.           (when (invalid-wrapper-p wrapper)
  1837.             (setq invalid-wrapper-p t)
  1838.             (setq wrapper (fast-check-wrapper-validity arg)))
  1839.           (push wrapper dfun-wrappers-rev)
  1840.           (let ((wclass (wrapper-class wrapper)))
  1841.             (values wrapper wclass `(class-eq ,wclass)))))
  1842.       (push wrapper wrappers-rev)
  1843.           (push class classes-rev)
  1844.           (push type types-rev))))
  1845.     (let* ((wrappers (nreverse wrappers-rev))
  1846.        (classes (nreverse classes-rev))
  1847.        (types (mapcar #'(lambda (class) `(class-eq ,class)) classes)))
  1848.       (multiple-value-bind (methods all-applicable-and-sorted-p)
  1849.       (if cam-std-p
  1850.           (compute-applicable-methods-using-types gf types)
  1851.           (compute-applicable-methods-using-classes gf classes))
  1852.         (declare (type boolean all-applicable-and-sorted-p))
  1853.     (let ((sdfun (if (or all-applicable-and-sorted-p cam-std-p)
  1854.                          (funcall-function
  1855.                             (get-secondary-dispatch-function1 
  1856.                     gf methods types
  1857.                     all-applicable-and-sorted-p)
  1858.                             nil
  1859.                             (and for-cache-p wrappers))
  1860.              (default-secondary-dispatch-function gf))))
  1861.       (multiple-value-bind (accessor-type index)
  1862.               (if (and for-accessor-p all-applicable-and-sorted-p methods)
  1863.           (accessor-values arg-info classes methods)
  1864.                   (values nil nil))
  1865.         (values (if (and dfun-wrappers-rev (null (cdr dfun-wrappers-rev)))
  1866.             (car dfun-wrappers-rev)
  1867.             (nreverse dfun-wrappers-rev))
  1868.             invalid-wrapper-p
  1869.             sdfun methods accessor-type index)))))))
  1870.  
  1871. (defun sdfun-for-caching (gf classes)
  1872.   (let ((types (mapcar #'class-eq-type classes)))
  1873.     (multiple-value-bind (methods all-applicable-and-sorted-p)
  1874.     (compute-applicable-methods-using-types gf types)
  1875.       (method-function-funcall
  1876.          (get-secondary-dispatch-function1 
  1877.        gf methods types all-applicable-and-sorted-p)
  1878.        nil (mapcar #'class-wrapper classes)))))
  1879.  
  1880. (defun value-for-caching (gf classes)
  1881.   (let ((methods (compute-applicable-methods-using-types 
  1882.            gf (mapcar #'class-eq-type classes))))
  1883.     (method-constant-value (car methods))))
  1884.  
  1885. (defun default-secondary-dispatch-function (generic-function)
  1886.   #'(lambda (&rest args)
  1887.       (let ((methods (compute-applicable-methods generic-function args)))
  1888.     (if methods
  1889.         (method-function-apply
  1890.               (get-effective-method-function generic-function methods)
  1891.           args)
  1892.         (apply #'no-applicable-method generic-function args)))))
  1893.  
  1894. (defun list-eq (x y)
  1895.   (loop (when (atom x) (return (eq x y)))
  1896.     (when (atom y) (return nil))
  1897.     (unless (eq (car x) (car y)) (return nil))
  1898.     (setq x (cdr x)  y (cdr y))))
  1899.  
  1900. (defvar *std-cam-methods* nil)
  1901.  
  1902. (declaim (ftype (function (T) (values T boolean))
  1903.                 compute-applicable-methods-emf))
  1904. (defun compute-applicable-methods-emf (generic-function)  
  1905.   (if (eq *boot-state* 'complete)
  1906.       (let* ((cam (gdefinition 'compute-applicable-methods))
  1907.          (cam-methods (compute-applicable-methods-using-types
  1908.                cam (list `(eql ,generic-function) t))))
  1909.     (values (get-effective-method-function cam cam-methods)
  1910.         (list-eq cam-methods 
  1911.              (or *std-cam-methods*
  1912.                  (setq *std-cam-methods*
  1913.                    (compute-applicable-methods-using-types
  1914.                     cam (list `(eql ,cam) t)))))))
  1915.       (values #'compute-applicable-methods-function t)))
  1916.  
  1917. (declaim (ftype (function (T) boolean) compute-applicable-methods-emf-std-p))
  1918. (defun compute-applicable-methods-emf-std-p (gf)
  1919.   (gf-info-c-a-m-emf-std-p (gf-arg-info gf)))
  1920.  
  1921. (defvar *old-c-a-m-gf-methods* nil)
  1922.  
  1923. (defun update-all-c-a-m-gf-info (c-a-m-gf)
  1924.   (let ((methods (generic-function-methods c-a-m-gf)))
  1925.     (if (every #'(lambda (old-method)
  1926.            (memq old-method methods))
  1927.            *old-c-a-m-gf-methods*)
  1928.     (let ((gfs-to-do nil)
  1929.           (gf-classes-to-do nil))
  1930.       (dolist (method methods)
  1931.         (unless (memq method *old-c-a-m-gf-methods*)
  1932.           (let ((specl (car (method-specializers method))))
  1933.         (if (eql-specializer-p specl)
  1934.             (pushnew (specializer-object specl) gfs-to-do)
  1935.             (pushnew (specializer-class specl) gf-classes-to-do)))))
  1936.       (map-all-generic-functions 
  1937.        #'(lambda (gf)
  1938.            (when (or (memq gf gfs-to-do)
  1939.                          (let ((cpl (wrapper-class-precedence-list
  1940.                                       (fast-wrapper-of gf))))
  1941.                (dolist (class gf-classes-to-do nil)
  1942.                              (if (memq class cpl) (return T)))))
  1943.          (update-c-a-m-gf-info gf)))))
  1944.     (map-all-generic-functions #'update-c-a-m-gf-info))
  1945.     (setq *old-c-a-m-gf-methods* methods)))
  1946.  
  1947. (defun update-gf-info (gf)
  1948.   (update-c-a-m-gf-info gf)
  1949.   (update-gf-simple-accessor-type gf))
  1950.  
  1951. (defun update-c-a-m-gf-info (gf)
  1952.   (multiple-value-bind (c-a-m-emf std-p)
  1953.       (compute-applicable-methods-emf gf)
  1954.     (declare (type boolean std-p))
  1955.     (let ((arg-info (gf-arg-info gf)))
  1956.       (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
  1957.       (setf (gf-info-c-a-m-emf-std-p arg-info) std-p))))
  1958.  
  1959. (defun update-gf-simple-accessor-type (gf)
  1960.   (let ((arg-info (gf-arg-info gf)))
  1961.     (setf (gf-info-simple-accessor-type arg-info)
  1962.       (let* ((methods (generic-function-methods gf))
  1963.          (class (and methods (class-of (car methods))))
  1964.          (type (and class
  1965.                            (cond ((eq class *the-class-standard-reader-method*)
  1966.                   'reader)
  1967.                  ((eq class *the-class-standard-writer-method*)
  1968.                   'writer)
  1969.                  ((eq class *the-class-standard-boundp-method*)
  1970.                   'boundp)))))
  1971.         (when (and (gf-info-c-a-m-emf-std-p arg-info)
  1972.                type
  1973.                (dolist (method (cdr methods) t)
  1974.              (unless (eq class (class-of method)) (return nil)))
  1975.                (eq (generic-function-method-combination gf)
  1976.                *standard-method-combination*))
  1977.           type)))))
  1978.  
  1979. (declaim (ftype (function (T T) boolean)
  1980.                 accessor-methods-safe-to-use-slot-wrapper-optimizations-p))
  1981. (defun accessor-methods-safe-to-use-slot-wrapper-optimizations-p
  1982.        (methods type)
  1983.   ;; Returns whether all accessor-methods Methods are safe for the slot-value
  1984.   ;; wrapper optimizations.
  1985.   (let ((safe-specializers
  1986.           (ecase type
  1987.             (reader *safe-slot-value-using-class-specializers*)
  1988.             (writer *safe-set-slot-value-using-class-specializers*)
  1989.             (boundp *safe-slot-boundp-using-class-specializers*))))
  1990.     (declare (type list safe-specializers))
  1991.     (dolist (method methods T)
  1992.       (unless (member (mapcar #'class-name (method-specializers method))
  1993.                       safe-specializers :test #'equal)
  1994.         (return NIL)))))
  1995.  
  1996. (declaim (ftype (function (T T) boolean) slot-values-safe-using-class-p))
  1997. (defun slot-values-safe-using-class-p (class slotd)
  1998.   (let ((types1 (list class (class-prototype class) slotd)))
  1999.     (and (or *safe-to-use-slot-value-wrapper-optimizations-p*
  2000.              (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
  2001.                (compute-applicable-methods #'slot-value-using-class types1)
  2002.                'reader))
  2003.          (or *safe-to-use-set-slot-value-wrapper-optimizations-p*
  2004.              (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
  2005.                (compute-applicable-methods
  2006.                  (gdefinition '(setf slot-value-using-class)) (cons T types1))
  2007.                'writer))
  2008.          (or *safe-to-use-slot-boundp-wrapper-optimizations-p*
  2009.              (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
  2010.                (compute-applicable-methods #'slot-boundp-using-class types1)
  2011.                'boundp)))))
  2012.  
  2013.                                        
  2014. (declaim (ftype (function (T T T T) (values function boolean))
  2015.                 get-accessor-method-function))
  2016. (defun get-accessor-method-function (gf type class slotd)  
  2017.   (let* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
  2018.      (types (if (eq type 'writer) `(t ,@types1) types1))
  2019.      (methods (compute-applicable-methods-using-types gf types))
  2020.      (std-p (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
  2021.                   methods type)))
  2022.     (declare (type list methods) (type boolean std-p))
  2023.     (values
  2024.      (if std-p
  2025.      (get-optimized-std-accessor-method-function class slotd type)
  2026.      (let ((wrappers NIL))
  2027.        (unless (and (eq type 'writer)
  2028.             (dolist (method methods t)
  2029.               (unless (eq (car (method-specializers method))
  2030.                       *the-class-t*)
  2031.                 (return nil))))
  2032.              (setf wrappers (list (wrapper-of class)
  2033.                   (class-wrapper class)
  2034.                   (wrapper-of slotd)))
  2035.          (when (eq type 'writer)
  2036.            (setf wrappers (cons (class-wrapper *the-class-t*) wrappers))))
  2037.        (get-accessor-from-svuc-method-function
  2038.         class slotd
  2039.         (get-secondary-dispatch-function 
  2040.          gf methods types
  2041.              (let ((alist ()))
  2042.                (dolist (method (reverse methods))
  2043.                  (push (list method
  2044.                              (method-function-for-caching method wrappers))
  2045.                        alist))
  2046.                alist)
  2047.              wrappers)
  2048.         type)))
  2049.      std-p)))
  2050.  
  2051. (defvar *new-class* nil)
  2052.  
  2053. ;used by optimize-slot-value-by-class-p (vector.lisp)
  2054. (defun update-slot-value-gf-info (gf type)
  2055.   (let* ((old-safe-p
  2056.            (ecase type
  2057.              (reader *safe-to-use-slot-value-wrapper-optimizations-p*)
  2058.              (writer *safe-to-use-set-slot-value-wrapper-optimizations-p*)
  2059.              (boundp *safe-to-use-slot-boundp-wrapper-optimizations-p*)))
  2060.          (newly-unsafe-p
  2061.            (and old-safe-p
  2062.                 (not (accessor-methods-safe-to-use-slot-wrapper-optimizations-p
  2063.                      (generic-function-methods gf) type)))))
  2064.     (declare (type boolean old-safe-p newly-unsafe-p))
  2065.     (unless *new-class*
  2066.       (update-std-or-str-methods gf type))
  2067.     (when (and (standard-svuc-method type) (structure-svuc-method type))
  2068.       (flet ((update-class (class)
  2069.            (when (class-finalized-p class)
  2070.              (dolist (slotd (class-slots class))
  2071.             (multiple-value-bind (function std-p)
  2072.                 (get-accessor-method-function gf type class slotd)
  2073.               #+kcl (si:turbo-closure function)
  2074.               (setf (slot-accessor-std-p slotd type) std-p)
  2075.                       (update-slot-accessor-function slotd type function T))
  2076.                     (when newly-unsafe-p
  2077.                       (ecase type
  2078.                         (reader (initialize-internal-slot-reader-gfs
  2079.                                   (slot-definition-name slotd)))
  2080.                         (writer (initialize-internal-slot-writer-gfs
  2081.                                   (slot-definition-name slotd)))
  2082.                         (boundp (initialize-internal-slot-boundp-gfs
  2083.                                   (slot-definition-name slotd)))))))))
  2084.         (if *new-class*
  2085.         (update-class *new-class*)
  2086.         (map-all-classes #'update-class 'slot-object))))
  2087.     (when newly-unsafe-p
  2088.       (when *always-safe-to-use-slot-wrapper-optimizations-p*
  2089.         (cerror "Continue even though previously compiled slot-value accesses
  2090.                  might ignore it?"
  2091.                 "Defining user ~S method when PCL was told to assume there
  2092.                  wouldn't be any (~S was set to T)."
  2093.                 (generic-function-name gf)
  2094.                 '*always-safe-to-use-slot-wrapper-optimizations-p*)
  2095.         (setf *always-safe-to-use-slot-wrapper-optimizations-p* NIL))
  2096.       (setf *safe-to-use-slot-wrapper-optimizations-p* NIL)
  2097.       (ecase type
  2098.         (reader
  2099.      (setf *safe-to-use-slot-value-wrapper-optimizations-p* NIL))
  2100.         (writer
  2101.      (setf *safe-to-use-set-slot-value-wrapper-optimizations-p* NIL))
  2102.         (boundp
  2103.      (setf *safe-to-use-slot-boundp-wrapper-optimizations-p* NIL))))
  2104.     (unless *safe-to-use-slot-wrapper-optimizations-p*
  2105.       (dolist (gf *generic-functions-having-cached-closures*)
  2106.         (update-dfun gf)))
  2107.     (fix-dfuns-needing-update)))
  2108.  
  2109.  
  2110.  
  2111. (defvar *standard-slot-value-using-class-method* nil)
  2112. (defvar *standard-setf-slot-value-using-class-method* nil)
  2113. (defvar *standard-slot-boundp-using-class-method* nil)
  2114. (defvar *structure-slot-value-using-class-method* nil)
  2115. (defvar *structure-setf-slot-value-using-class-method* nil)
  2116. (defvar *structure-slot-boundp-using-class-method* nil)
  2117.  
  2118. (defun standard-svuc-method (type)
  2119.   (case type
  2120.     (reader *standard-slot-value-using-class-method*)
  2121.     (writer *standard-setf-slot-value-using-class-method*)
  2122.     (boundp *standard-slot-boundp-using-class-method*)))
  2123.  
  2124. (defun set-standard-svuc-method (type method)
  2125.   (case type
  2126.     (reader (setq *standard-slot-value-using-class-method* method))
  2127.     (writer (setq *standard-setf-slot-value-using-class-method* method))
  2128.     (boundp (setq *standard-slot-boundp-using-class-method* method))))
  2129.  
  2130. (defun structure-svuc-method (type)
  2131.   (case type
  2132.     (reader *structure-slot-value-using-class-method*)
  2133.     (writer *structure-setf-slot-value-using-class-method*)
  2134.     (boundp *structure-slot-boundp-using-class-method*)))
  2135.  
  2136. (defun set-structure-svuc-method (type method)
  2137.   (case type
  2138.     (reader (setq *structure-slot-value-using-class-method* method))
  2139.     (writer (setq *structure-setf-slot-value-using-class-method* method))
  2140.     (boundp (setq *structure-slot-boundp-using-class-method* method))))
  2141.  
  2142. (defun update-std-or-str-methods (gf type)
  2143.   (dolist (method (generic-function-methods gf))
  2144.     (let ((specls (method-specializers method)))
  2145.       (when (and (or (not (eq type 'writer))
  2146.              (eq (pop specls) *the-class-t*))
  2147.          (every #'classp specls))
  2148.     (cond ((and (eq (class-name (car specls))
  2149.             'std-class)
  2150.             (eq (class-name (cadr specls)) 
  2151.             'standard-object)
  2152.             (eq (class-name (caddr specls)) 
  2153.             'standard-effective-slot-definition))
  2154.            (set-standard-svuc-method type method))
  2155.           ((and (eq (class-name (car specls))
  2156.             'structure-class)
  2157.             (eq (class-name (cadr specls))
  2158.             'structure-object)
  2159.             (eq (class-name (caddr specls)) 
  2160.             'structure-effective-slot-definition))
  2161.            (set-structure-svuc-method type method)))))))
  2162.  
  2163. (defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
  2164.  
  2165. (defmacro with-hash-table ((table test) &body forms)
  2166.   `(let* ((.free. (assoc ',test *free-hash-tables*))
  2167.       (,table (if (cdr .free.)
  2168.               (pop (cdr .free.))
  2169.               (make-hash-table :test ',test))))
  2170.      (multiple-value-prog1
  2171.      (progn ,@forms)
  2172.        (clrhash ,table)
  2173.        (push ,table (cdr .free.)))))
  2174.  
  2175. (defmacro with-eq-hash-table ((table) &body forms)
  2176.   `(with-hash-table (,table eq) ,@forms))
  2177.  
  2178. (defmacro with-equal-hash-table ((table) &body forms)
  2179.   `(with-hash-table (,table equal) ,@forms))
  2180.  
  2181. (declaim (ftype (function (T T &optional T)
  2182.                           (values T T T T (or index null) boolean))
  2183.                 make-accessor-table))
  2184. (defun make-accessor-table (generic-function type &optional table)
  2185.   (unless table (setq table (make-hash-table :test 'eq)))
  2186.   (let ((methods (generic-function-methods generic-function))
  2187.     (all-index nil)
  2188.     (no-class-slots-p t)
  2189.     first second (size 0))
  2190.     (declare (type index size) (type boolean no-class-slots-p))
  2191.     ;; class -> {(specl slotd)}
  2192.     (dolist (method methods)
  2193.     (let* ((specializers (method-specializers method))
  2194.            (specl (if (eq type 'reader)
  2195.               (car specializers)
  2196.               (cadr specializers)))
  2197.                (standard-object-p (class-standard-p specl))
  2198.            (slot-name (accessor-method-slot-name method)))
  2199.           (declare (type boolean standard-object-p))
  2200.       (when (and (not standard-object-p)
  2201.                      (class-on-class-precedence-list-p
  2202.                        *the-class-structure-object* specl))
  2203.         (return-from make-accessor-table nil))
  2204.           (let ((slotd-table (gethash slot-name *name->class->slotd-table*)))
  2205.             (when slotd-table
  2206.           (maphash #'(lambda (class slotd)
  2207.                            (when (class-on-class-precedence-list-p specl class)
  2208.                  (unless (and (or standard-object-p
  2209.                                               (class-standard-p class))
  2210.                       (slot-accessor-std-p slotd type))
  2211.                    (return-from make-accessor-table nil))
  2212.                  (push (cons specl slotd) (gethash class table))))
  2213.                slotd-table)))))
  2214.     (maphash #'(lambda (class specl+slotd-list)
  2215.                  (assure-finalized class)
  2216.          (dolist (sclass (class-precedence-list class)
  2217.               (error "This can't happen"))
  2218.            (let ((a (assq sclass specl+slotd-list)))
  2219.              (when a
  2220.                (let* ((slotd (cdr a))
  2221.                   (index (slot-definition-location slotd)))
  2222.              (unless index (return-from make-accessor-table nil))
  2223.              (setf (gethash class table) index)
  2224.              (when (consp index) (setq no-class-slots-p nil))
  2225.              (setq all-index (if (or (null all-index)
  2226.                          (eql all-index index))
  2227.                          index t))
  2228.              (setf size (the index (1+ size)))
  2229.              (cond ((= size 1) (setq first class))
  2230.                    ((= size 2) (setq second class)))
  2231.              (return nil))))))
  2232.          table)
  2233.     (values table all-index first second size no-class-slots-p)))
  2234.  
  2235. (defun mec-all-classes-internal (spec precompute-p)
  2236.   (cons (specializer-class spec)
  2237.     (and (classp spec)
  2238.          precompute-p
  2239.          (not (or (eq spec *the-class-t*)
  2240.               (eq spec *the-class-slot-object*)
  2241.               (eq spec *the-class-standard-object*)
  2242.               (eq spec *the-class-structure-object*)))
  2243.          (let ((sc (class-direct-subclasses spec)))
  2244.            (when sc
  2245.          (mapcan #'(lambda (class)
  2246.                  (mec-all-classes-internal class precompute-p))
  2247.              sc))))))
  2248.  
  2249. (defun mec-all-classes (spec precompute-p)
  2250.   (let ((classes (mec-all-classes-internal spec precompute-p)))
  2251.     (if (null (cdr classes))
  2252.     classes
  2253.     (let* ((a-classes (cons nil classes))
  2254.            (tail classes))
  2255.       (loop (when (null (cdr tail))
  2256.           (return (cdr a-classes)))
  2257.         (let ((class (cadr tail))
  2258.               (ttail (cddr tail)))
  2259.           (if (dolist (c ttail nil)
  2260.             (when (eq class c) (return t)))
  2261.               (setf (cdr tail) (cddr tail))
  2262.               (setf tail (cdr tail)))))))))
  2263.  
  2264. (defun mec-all-class-lists (spec-list precompute-p)
  2265.   (if (null spec-list)
  2266.       (list nil)
  2267.       (let* ((car-all-classes (mec-all-classes (car spec-list) precompute-p))
  2268.          (all-class-lists (mec-all-class-lists (cdr spec-list) precompute-p)))
  2269.     (mapcan #'(lambda (list)
  2270.             (mapcar #'(lambda (c) (cons c list)) car-all-classes))
  2271.         all-class-lists))))
  2272.  
  2273. (defun make-emf-cache (generic-function valuep cache classes-list new-class)
  2274.   (let* ((arg-info (gf-arg-info generic-function))
  2275.      (nkeys (arg-info-nkeys arg-info))
  2276.      (metatypes (arg-info-metatypes arg-info))
  2277.      (wrappers (unless (eq nkeys 1) (make-list nkeys)))
  2278.      (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
  2279.      (default '(default)))
  2280.     (declare (type index nkeys)
  2281.              (type boolean precompute-p))
  2282.     (flet ((add-class-list (classes)
  2283.          (when (or (null new-class) (memq new-class classes))
  2284.            (let ((wrappers (get-wrappers-from-classes 
  2285.                  nkeys wrappers classes metatypes)))
  2286.          (when (and wrappers
  2287.                             (eq default (probe-cache cache wrappers default)))
  2288.            (let ((value (cond ((eq valuep t)
  2289.                        (sdfun-for-caching generic-function classes))
  2290.                       ((eq valuep :constant-value)
  2291.                        (value-for-caching generic-function classes)))))
  2292.              (setq cache (fill-cache cache wrappers value t))))))))
  2293.       (if classes-list
  2294.       (mapc #'add-class-list classes-list)
  2295.       (dolist (method (generic-function-methods generic-function))
  2296.         (mapc #'add-class-list
  2297.           (mec-all-class-lists (method-specializers method) precompute-p))))
  2298.       cache)))
  2299.  
  2300. (declaim (ftype (function (T) boolean) methods-contain-eql-specializer-p))
  2301. (defun methods-contain-eql-specializer-p (methods)
  2302.   (dolist (method methods nil)
  2303.     (when (dolist (spec (method-specializers method) nil)
  2304.         (when (eql-specializer-p spec) (return t)))
  2305.       (return t))))
  2306.  
  2307. (defmacro class-test (arg class)
  2308.   (cond ((eq class *the-class-t*)
  2309.      't)
  2310.     ((eq class *the-class-slot-object*)
  2311.      `(not (eq *the-class-built-in-class* 
  2312.         (wrapper-class (std-instance-wrapper (class-of ,arg))))))
  2313.     ((eq class *the-class-standard-object*)
  2314.      `(or (std-instance-p ,arg)
  2315.               (fsc-instance-p ,arg)
  2316.               (typep ,arg 'standard-object)))
  2317.         ((or (and (structure-class-p class)
  2318.                   (not (eq class *the-class-structure-object*)))
  2319.              (eq (class-of class) *the-class-built-in-class*))
  2320.          `(typep ,arg ',(class-name class)))
  2321.     (t
  2322.      `(memq ',class (wrapper-class-precedence-list
  2323.               (fast-wrapper-of ,arg))))))
  2324.  
  2325. (defmacro class-eq-test (arg class)
  2326.   `(eq (class-of ,arg) ',class))
  2327.  
  2328. (defmacro eql-test (arg object)
  2329.   `(eql ,arg ',object))
  2330.  
  2331. (defun dnet-methods-p (form)
  2332.   (and (consp form)
  2333.        (or (eq (car form) 'methods)
  2334.        (eq (car form) 'unordered-methods))))
  2335.  
  2336. (defmacro scase (arg &rest clauses) ; This is case, but without gensyms
  2337.   `(let ((.case-arg. ,arg))
  2338.      (cond ,@(mapcar #'(lambda (clause)
  2339.              (list* (cond ((listp (car clause))
  2340.                        `(memq .case-arg. ',(car clause)))
  2341.                       ((memq (car clause) '(t otherwise))
  2342.                        `t)
  2343.                       (t
  2344.                        `(eql .case-arg. ',(car clause))))
  2345.                 nil
  2346.                 (cdr clause)))
  2347.              clauses))))
  2348.  
  2349. (defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses))
  2350.  
  2351. (defun generate-discrimination-net (generic-function methods types sorted-p)
  2352.   (let* ((arg-info (gf-arg-info generic-function))
  2353.      (precedence (arg-info-precedence arg-info)))
  2354.     (generate-discrimination-net-internal 
  2355.      generic-function methods types
  2356.      #'(lambda (methods known-types)
  2357.      (if (or sorted-p
  2358.          (block one-order-p
  2359.            (let ((sorted-methods nil))
  2360.              (map-all-orders 
  2361.               (copy-list methods) precedence
  2362.               #'(lambda (methods)
  2363.               (when sorted-methods (return-from one-order-p nil))
  2364.               (setq sorted-methods methods)))
  2365.              (setq methods sorted-methods))
  2366.            t))
  2367.          `(methods ,methods ,known-types)
  2368.          `(unordered-methods ,methods ,known-types)))
  2369.      #'(lambda (position type true-value false-value)
  2370.      (let ((arg (dfun-arg-symbol position)))
  2371.        (if (eq (car type) 'eql)
  2372.            (let* ((false-case-p (and (consp false-value)
  2373.                      (or (eq (car false-value) 'scase)
  2374.                          (eq (car false-value) 'mcase))
  2375.                      (eq arg (cadr false-value))))
  2376.               (false-clauses (if false-case-p
  2377.                      (cddr false-value)
  2378.                      `((t ,false-value))))
  2379.               (case-sym (if (and (dnet-methods-p true-value)
  2380.                      (if false-case-p
  2381.                          (eq (car false-value) 'mcase)
  2382.                          (dnet-methods-p false-value)))
  2383.                     'mcase
  2384.                     'scase))
  2385.               (type-sym (if (memq (cadr type) '(t nil otherwise))
  2386.                     `(,(cadr type))
  2387.                     (cadr type))))
  2388.          `(,case-sym ,arg
  2389.             (,type-sym ,true-value)
  2390.             ,@false-clauses))
  2391.            `(if ,(let ((arg (dfun-arg-symbol position)))
  2392.                (case (car type)
  2393.              (class    `(class-test    ,arg ,(cadr type)))
  2394.              (class-eq `(class-eq-test ,arg ,(cadr type)))))
  2395.             ,true-value
  2396.             ,false-value))))
  2397.      #'identity)))
  2398.  
  2399. (defun class-from-type (type)
  2400.   (if (or (atom type) (eq (car type) 't))
  2401.       *the-class-t*
  2402.       (case (car type)
  2403.     (and (dolist (type (cdr type) *the-class-t*)
  2404.            (when (and (consp type) (not (eq (car type) 'not)))
  2405.          (return (class-from-type type)))))
  2406.     (not *the-class-t*)
  2407.         (eql (class-of (cadr type)))
  2408.         (class-eq (cadr type))
  2409.         (class (cadr type)))))
  2410.  
  2411. (defun precompute-effective-methods (gf &optional classes-list-p)
  2412.   (let* ((arg-info (gf-arg-info gf))
  2413.      (methods (generic-function-methods gf))
  2414.      (precedence (arg-info-precedence arg-info))
  2415.      (*in-precompute-effective-methods-p* t)
  2416.      (classes-list nil))
  2417.     (generate-discrimination-net-internal 
  2418.      gf methods nil
  2419.      #'(lambda (methods known-types)
  2420.      (when methods
  2421.        (when classes-list-p
  2422.          (push (mapcar #'class-from-type known-types) classes-list))
  2423.        (map-all-orders 
  2424.           methods precedence
  2425.           #'(lambda (methods)
  2426.           (get-secondary-dispatch-function gf methods known-types)))))
  2427.      #'(lambda (position type true-value false-value)
  2428.      (declare (ignore position type true-value false-value))
  2429.      nil)
  2430.      #'(lambda (type)
  2431.      (if (and (consp type) (eq (car type) 'eql))
  2432.          `(class-eq ,(class-of (cadr type)))
  2433.          type)))
  2434.     classes-list))
  2435.  
  2436. ; we know that known-type implies neither new-type nor `(not ,new-type) 
  2437. (defun augment-type (new-type known-type)
  2438.   (if (or (eq known-type 't)
  2439.       (eq (car new-type) 'eql))
  2440.       new-type
  2441.       (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and))
  2442.             (cdr known-type)
  2443.             (list known-type))))
  2444.     (unless (eq (car new-type) 'not)
  2445.       (setq so-far
  2446.         (mapcan #'(lambda (type)
  2447.                 (unless (*subtypep new-type type)
  2448.                   (list type)))
  2449.             so-far)))
  2450.     (if (null so-far)
  2451.         new-type
  2452.         `(and ,new-type ,@so-far)))))
  2453.  
  2454. (defun generate-discrimination-net-internal-do-column (p-tail contenders known-types)
  2455.   (declare (special types methods-function nreq metatypes))
  2456.   (if p-tail
  2457.       (let* ((position (car p-tail))
  2458.          (known-type (or (nth position types) t)))
  2459.         (declare (type index position))
  2460.     (if (eq (nth position metatypes) 't)
  2461.         (generate-discrimination-net-internal-do-column
  2462.               (cdr p-tail) contenders (cons (cons position known-type) known-types))
  2463.         (generate-discrimination-net-internal-do-methods
  2464.                p-tail contenders known-type () known-types)))
  2465.       (funcall-function methods-function contenders 
  2466.            (let ((k-t (make-list (the index nreq))))
  2467.          (dolist (index+type known-types)
  2468.            (setf (nth (the index (car index+type)) k-t)
  2469.                  (cdr index+type)))
  2470.              k-t))))
  2471.  
  2472. (defun generate-discrimination-net-internal-do-methods
  2473.    (p-tail contenders known-type winners known-types)
  2474.   (declare (special test-function type-function))
  2475.   ;;
  2476.   ;; <contenders>
  2477.   ;;   is a (sorted) list of methods that must be discriminated
  2478.   ;; <known-type>
  2479.   ;;   is the type of this argument, constructed from tests already made.
  2480.   ;; <winners>
  2481.   ;;   is a (sorted) list of methods that are potentially applicable
  2482.   ;;   after the discrimination has been made.
  2483.   ;;   
  2484.   (if (null contenders)
  2485.       (generate-discrimination-net-internal-do-column
  2486.         (cdr p-tail) winners (cons (cons (car p-tail) known-type) known-types))
  2487.       (let* ((position (car p-tail))
  2488.          (method (car contenders))
  2489.          (specl (nth position (method-specializers method)))
  2490.              (type (funcall-function type-function (type-from-specializer specl))))
  2491.         (declare (type index position))
  2492.     (multiple-value-bind (app-p maybe-app-p)
  2493.        (specializer-applicable-using-type-p type known-type)
  2494.           (declare (type boolean app-p maybe-app-p))
  2495.       (flet ((determined-to-be (truth-value)
  2496.            (if truth-value app-p (not maybe-app-p)))
  2497.          (do-if (truth &optional implied)
  2498.            (let ((ntype (if truth type `(not ,type))))
  2499.              (generate-discrimination-net-internal-do-methods p-tail
  2500.             (cdr contenders)
  2501.             (if implied
  2502.                 known-type
  2503.                 (augment-type ntype known-type))
  2504.             (if truth
  2505.                 (append winners `(,method))
  2506.                 winners)
  2507.             known-types))))
  2508.         (cond ((determined-to-be nil) (do-if nil t))
  2509.           ((determined-to-be t)   (do-if t   t))
  2510.           (t (funcall-function test-function position type 
  2511.                            (do-if t) (do-if nil)))))))))
  2512.  
  2513. (defun generate-discrimination-net-internal
  2514.     (gf methods types methods-function test-function type-function)
  2515.   (declare (special types methods-function test-function type-function))
  2516.   (let* ((arg-info (gf-arg-info gf))
  2517.      (precedence (arg-info-precedence arg-info))
  2518.      (nreq (arg-info-number-required arg-info))
  2519.      (metatypes (arg-info-metatypes arg-info)))
  2520.     (declare (type index nreq))
  2521.     (declare (special nreq metatypes))
  2522.       (generate-discrimination-net-internal-do-column precedence methods ())))
  2523.  
  2524. (defun compute-secondary-dispatch-function (generic-function net &optional 
  2525.                         method-alist wrappers)
  2526.   (funcall-function (compute-secondary-dispatch-function1 generic-function net)
  2527.             method-alist wrappers))
  2528.  
  2529. (defvar *case-table-limit* 10)
  2530. (declaim (type index *case-table-limit*))
  2531.  
  2532. (defun net-test-converter (form)
  2533.   (cond ((and (consp form) (eq (car form) 'methods))
  2534.      '.methods.)
  2535.     ((and (consp form) (eq (car form) 'unordered-methods))
  2536.      '.umethods.)
  2537.     ((and (consp form) (eq (car form) 'mcase)
  2538.           (< *case-table-limit* (length (the list (cddr form)))))
  2539.      '.mcase.)
  2540.     (t (default-test-converter form))))
  2541.  
  2542. (declaim (ftype (function (T T T) (values T list)) net-code-converter))
  2543. (defun net-code-converter (form metatypes applyp)
  2544.   (cond ((and (consp form) (or (eq (car form) 'methods)
  2545.                    (eq (car form) 'unordered-methods)))
  2546.      (let ((gensym (gensym)))
  2547.        (values (make-dfun-call metatypes applyp gensym)
  2548.            (list gensym))))
  2549.     ((and (consp form) (eq (car form) 'mcase)
  2550.           (< *case-table-limit* (length (the list (cddr form)))))
  2551.      (let ((gensym (gensym)) (default (gensym)))
  2552.        (values (make-dfun-call metatypes applyp 
  2553.                    `(gethash ,(cadr form) ,gensym ,default))
  2554.            (list gensym default))))
  2555.     (t (default-code-converter form))))
  2556.  
  2557. (defun net-constant-converter (form generic-function)
  2558.   (or (let ((c (methods-converter form generic-function)))
  2559.     (when c (list c)))
  2560.       (cond ((and (consp form) (eq (car form) 'mcase)
  2561.           (< *case-table-limit* (length (the list (cddr form)))))
  2562.          (let* ((list (mapcar #'(lambda (clause)
  2563.                       (let ((key (car clause))
  2564.                         (meth (cadr clause)))
  2565.                     (cons (if (consp key) (car key) key)
  2566.                           (methods-converter meth
  2567.                                  generic-function))))
  2568.                   (cddr form)))
  2569.             (default (car (last list))))
  2570.            (list (list* '.table. (nbutlast list))
  2571.              (cdr default))))
  2572.         (t (default-constant-converter form)))))
  2573.  
  2574. (defun methods-converter (form generic-function)
  2575.   (cond ((and (consp form) (eq (car form) 'methods))
  2576.      (cons '.methods.
  2577.            (get-effective-method-function1 generic-function (cadr form))))
  2578.     ((and (consp form) (eq (car form) 'unordered-methods))
  2579.      (default-secondary-dispatch-function generic-function))))
  2580.  
  2581. (defun convert-methods (constant method-alist wrappers)
  2582.   (if (and (consp constant)
  2583.        (eq (car constant) '.methods.))
  2584.       (funcall (cdr constant) method-alist wrappers)
  2585.       constant))
  2586.  
  2587. (defun convert-table (constant method-alist wrappers)
  2588.   (when (and (consp constant)
  2589.          (eq (car constant) '.table.))
  2590.     (let ((table (make-hash-table :test 'eql)))
  2591.       (dolist (k+v (cdr constant))
  2592.     (setf (gethash (car k+v) table)
  2593.           (convert-methods (cdr k+v) method-alist wrappers)))
  2594.       table)))
  2595.  
  2596. (defun compute-secondary-dispatch-function1 (generic-function net)
  2597.   (if (eq (car net) 'methods)
  2598.       (get-effective-method-function1 generic-function (cadr net))
  2599.       (multiple-value-bind (cfunction constants)
  2600.       (let* ((arg-info (gf-arg-info generic-function))
  2601.          (metatypes (arg-info-metatypes arg-info))
  2602.          (applyp (arg-info-applyp arg-info)))
  2603.             (declare (type boolean applyp))
  2604.         (get-function1 `(lambda ,(make-dfun-lambda-list metatypes applyp) ,net)
  2605.                #'net-test-converter
  2606.                #'(lambda (form)
  2607.                    (net-code-converter form metatypes applyp))
  2608.                #'(lambda (form)
  2609.                    (net-constant-converter form generic-function))))
  2610.     #'(lambda (method-alist wrappers)
  2611.         (apply-function
  2612.                    cfunction
  2613.            (mapcar #'(lambda (constant)
  2614.                    (or (convert-table constant method-alist wrappers)
  2615.                    (convert-methods constant method-alist wrappers)))
  2616.                constants))))))
  2617.  
  2618. (defvar *show-make-unordered-methods-emf-calls* nil)
  2619.  
  2620. (defun make-unordered-methods-emf (generic-function methods)
  2621.   (when *show-make-unordered-methods-emf-calls*
  2622.     (format t "~&make-unordered-methods-emf ~s~%" 
  2623.         (generic-function-name generic-function)))
  2624.   #'(lambda (&rest args)
  2625.       (let* ((types (types-from-arguments generic-function args 'eql))
  2626.          (smethods (sort-applicable-methods generic-function methods types))
  2627.          (emf (get-effective-method-function generic-function smethods)))
  2628.     (apply-function emf args))))
  2629.  
  2630. ;;;
  2631. ;;; NOTE: We are assuming a restriction on user code that the method
  2632. ;;;       combination must not change once it is connected to the
  2633. ;;;       generic function.
  2634. ;;;
  2635. ;;;       This has to be legal, because otherwise any kind of method
  2636. ;;;       lookup caching couldn't work.  See this by saying that this
  2637. ;;;       cache, is just a backing cache for the fast cache.  If that
  2638. ;;;       cache is legal, this one must be too.
  2639. ;;;
  2640. ;;; Don't clear this table!  
  2641. (defvar *effective-method-table* (make-hash-table :test 'eq))
  2642.  
  2643.  
  2644. (defun get-secondary-dispatch-function (gf methods types &optional 
  2645.                              method-alist wrappers)
  2646.   (funcall-function (get-secondary-dispatch-function1 
  2647.              gf methods types
  2648.              (not (methods-contain-eql-specializer-p methods)))
  2649.             method-alist wrappers))
  2650.  
  2651. (defun get-secondary-dispatch-function1 (gf methods types 
  2652.                         &optional all-applicable-p
  2653.                         (all-sorted-p t))
  2654.   (if (null methods)
  2655.       #'(lambda (method-alist wrappers)
  2656.       (declare (ignore method-alist wrappers))
  2657.       #'(lambda (&rest args)
  2658.           (apply #'no-applicable-method gf args)))
  2659.       (let* ((key (car methods))
  2660.          (ht-value (or (gethash key *effective-method-table*)
  2661.                (setf (gethash key *effective-method-table*)
  2662.                  (cons nil nil)))))
  2663.     (if (and (null (cdr methods)) all-applicable-p) ; the most common case
  2664.         (or (car ht-value)
  2665.         (setf (car ht-value)
  2666.               (get-secondary-dispatch-function2 
  2667.                gf methods types all-applicable-p all-sorted-p)))
  2668.         (let ((akey (list methods (if all-applicable-p 'all-applicable types))))
  2669.           (or (cdr (assoc akey (cdr ht-value) :test #'equal))
  2670.           (let ((value (get-secondary-dispatch-function2 
  2671.                 gf methods types all-applicable-p all-sorted-p)))
  2672.             (push (cons akey value) (cdr ht-value))
  2673.             value)))))))
  2674.  
  2675. (defun get-secondary-dispatch-function2 (gf methods types all-applicable-p all-sorted-p)
  2676.   (if (and all-applicable-p all-sorted-p)
  2677.       (let* ((combin (generic-function-method-combination gf))
  2678.          (effective (compute-effective-method gf combin methods)))
  2679.     (make-effective-method-function1 gf effective))
  2680.       (let ((net (generate-discrimination-net 
  2681.           gf methods types all-sorted-p)))
  2682.     (compute-secondary-dispatch-function1 gf net))))
  2683.  
  2684. (defun get-effective-method-function (gf methods &optional method-alist wrappers)
  2685.   (funcall-function (get-secondary-dispatch-function1 gf methods nil t)
  2686.             method-alist wrappers))
  2687.  
  2688. (defun get-effective-method-function1 (gf methods &optional (sorted-p t))
  2689.   (get-secondary-dispatch-function1 gf methods nil t sorted-p))
  2690.  
  2691. (defun get-dispatch-function (gf)
  2692.   (let ((methods (generic-function-methods gf)))
  2693.     (funcall-function (get-secondary-dispatch-function1 gf methods nil nil nil)
  2694.               nil nil)))
  2695.  
  2696. ;;;
  2697. ;;; The value returned by compute-discriminating-function is a function
  2698. ;;; object.  It is called a discriminating function because it is called
  2699. ;;; when the generic function is called and its role is to discriminate
  2700. ;;; on the arguments to the generic function and then call appropriate
  2701. ;;; method functions.
  2702. ;;; 
  2703. ;;; A discriminating function can only be called when it is installed as
  2704. ;;; the funcallable instance function of the generic function for which
  2705. ;;; it was computed.
  2706. ;;;
  2707. ;;; More precisely, if compute-discriminating-function is called with an
  2708. ;;; argument <gf1>, and returns a result <df1>, that result must not be
  2709. ;;; passed to apply or funcall directly.  Rather, <df1> must be stored as
  2710. ;;; the funcallable instance function of the same generic function <gf1>
  2711. ;;; (using set-funcallable-instance-function).  Then the generic function
  2712. ;;; can be passed to funcall or apply.
  2713. ;;;
  2714. ;;; An important exception is that methods on this generic function are
  2715. ;;; permitted to return a function which itself ends up calling the value
  2716. ;;; returned by a more specific method.  This kind of `encapsulation' of
  2717. ;;; discriminating function is critical to many uses of the MOP.
  2718. ;;; 
  2719. ;;; As an example, the following canonical case is legal:
  2720. ;;;
  2721. ;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
  2722. ;;;     (let ((std (call-next-method)))
  2723. ;;;       #'(lambda (arg)
  2724. ;;;            (print (list 'call-to-gf gf arg))
  2725. ;;;            (funcall std arg))))
  2726. ;;;
  2727. ;;; Because many discriminating functions would like to use a dynamic
  2728. ;;; strategy in which the precise discriminating function changes with
  2729. ;;; time it is important to specify how a discriminating function is
  2730. ;;; permitted itself to change the funcallable instance function of the
  2731. ;;; generic function.
  2732. ;;;
  2733. ;;; Discriminating functions may set the funcallable instance function
  2734. ;;; of the generic function, but the new value must be generated by making
  2735. ;;; a call to COMPUTE-DISCRIMINATING-FUNCTION.  This is to ensure that any
  2736. ;;; more specific methods which may have encapsulated the discriminating
  2737. ;;; function will get a chance to encapsulate the new, inner discriminating
  2738. ;;; function.
  2739. ;;;
  2740. ;;; This implies that if a discriminating function wants to modify itself
  2741. ;;; it should first store some information in the generic function proper,
  2742. ;;; and then call compute-discriminating-function.  The appropriate method
  2743. ;;; on compute-discriminating-function will see the information stored in
  2744. ;;; the generic function and generate a discriminating function accordingly.
  2745. ;;;
  2746. ;;; The following is an example of a discriminating function which modifies
  2747. ;;; itself in accordance with this protocol:
  2748. ;;;
  2749. ;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
  2750. ;;;     #'(lambda (arg)
  2751. ;;;         (cond (<some condition>
  2752. ;;;                <store some info in the generic function>
  2753. ;;;                (set-funcallable-instance-function
  2754. ;;;                  gf
  2755. ;;;                  (compute-discriminating-function gf))
  2756. ;;;                (funcall gf arg))
  2757. ;;;               (t
  2758. ;;;                <call-a-method-of-gf>))))
  2759. ;;;
  2760. ;;; Whereas this code would not be legal:
  2761. ;;;
  2762. ;;;   (defmethod compute-discriminating-function ((gf my-generic-function))
  2763. ;;;     #'(lambda (arg)
  2764. ;;;         (cond (<some condition>
  2765. ;;;                (set-funcallable-instance-function
  2766. ;;;                  gf
  2767. ;;;                  #'(lambda (a) ..))
  2768. ;;;                (funcall gf arg))
  2769. ;;;               (t
  2770. ;;;                <call-a-method-of-gf>))))
  2771. ;;;
  2772. ;;; NOTE:  All the examples above assume that all instances of the class
  2773. ;;;        my-generic-function accept only one argument.
  2774. ;;;
  2775. ;;;
  2776. ;;;
  2777. ;;;
  2778. (defun gf-dfun-cache (gf)
  2779.   (let ((state (gf-dfun-state gf)))
  2780.     (typecase state
  2781.       (function nil)
  2782.       (cons (cadr state)))))
  2783.  
  2784. (defun gf-dfun-info (gf)
  2785.   (let ((state (gf-dfun-state gf)))
  2786.     (typecase state
  2787.       (function nil)
  2788.       (cons (cddr state)))))
  2789.  
  2790. (defun slot-value-using-class-dfun (class object slotd)
  2791.   (declare (ignore class))
  2792.   (method-function-funcall (slot-definition-reader-function slotd) object))
  2793.  
  2794. (defun setf-slot-value-using-class-dfun (new-value class object slotd)
  2795.   (declare (ignore class))
  2796.   (method-function-funcall (slot-definition-writer-function slotd) new-value object))
  2797.  
  2798. (defun slot-boundp-using-class-dfun (class object slotd)
  2799.   (declare (ignore class))
  2800.   (method-function-funcall (slot-definition-boundp-function slotd) object))
  2801.  
  2802. (defmethod compute-discriminating-function ((gf standard-generic-function))
  2803.   (with-slots (dfun-state arg-info) gf
  2804.     (typecase dfun-state
  2805.       (null (let ((name (generic-function-name gf)))
  2806.           (when (eq name 'compute-applicable-methods)
  2807.         (update-all-c-a-m-gf-info gf))
  2808.           (cond ((eq name 'slot-value-using-class)
  2809.              (update-slot-value-gf-info gf 'reader)
  2810.              #'slot-value-using-class-dfun)
  2811.             ((equal name '(setf slot-value-using-class))
  2812.              (update-slot-value-gf-info gf 'writer)
  2813.              #'setf-slot-value-using-class-dfun)
  2814.             ((eq name 'slot-boundp-using-class)
  2815.              (update-slot-value-gf-info gf 'boundp)
  2816.              #'slot-boundp-using-class-dfun)
  2817.             ((gf-precompute-dfun-and-emf-p arg-info)
  2818.              (make-final-dfun gf))
  2819.             (t
  2820.              (make-initial-dfun gf)))))
  2821.       (function dfun-state)
  2822.       (cons (car dfun-state)))))
  2823.  
  2824. (defun set-dfun (generic-function &optional dfun cache info)
  2825.   (setf (gf-dfun-state generic-function) 
  2826.     (if (and dfun (or cache info))
  2827.         (list* dfun cache info)
  2828.         dfun))
  2829.   dfun)
  2830.  
  2831. (defun update-dfun (generic-function &optional dfun cache info)
  2832.   (let ((ocache (gf-dfun-cache generic-function)))
  2833.     (set-dfun generic-function dfun cache info)
  2834.     (let ((dfun (compute-discriminating-function generic-function))
  2835.       (gf-name (generic-function-name generic-function)))
  2836.       (unless (eq 'default-method-only (type-of (gf-dfun-info generic-function)))
  2837.     (setq dfun (doctor-dfun-for-the-debugger 
  2838.             generic-function
  2839.             #+cmu dfun #-cmu (set-function-name dfun gf-name))))
  2840.       (set-funcallable-instance-function generic-function dfun)
  2841.       #+cmu (set-function-name generic-function gf-name)
  2842.       (when (and ocache (not (eq ocache cache))) (free-cache ocache))
  2843.       (setf *dfuns-needing-update* (remove gf-name *dfuns-needing-update*))
  2844.       dfun)))
  2845.  
  2846. (defmethod update-gf-dfun ((class std-class) gf)
  2847.   (let ((*new-class* class)
  2848.     (name (generic-function-name gf))
  2849.     (arg-info (gf-arg-info gf)))
  2850.     (cond ((eq name 'slot-value-using-class)
  2851.        (update-slot-value-gf-info gf 'reader))
  2852.       ((equal name '(setf slot-value-using-class))
  2853.        (update-slot-value-gf-info gf 'writer))
  2854.       ((eq name 'slot-boundp-using-class)
  2855.        (update-slot-value-gf-info gf 'boundp))
  2856.       ((gf-precompute-dfun-and-emf-p arg-info)
  2857.        (multiple-value-bind (dfun cache info)
  2858.            (make-final-dfun-internal gf)
  2859.          (set-dfun gf dfun cache info) ; otherwise cache might get freed twice
  2860.          (update-dfun gf dfun cache info))))))
  2861.  
  2862. ;;;
  2863. ;;;
  2864. ;;;
  2865. (declaim (ftype (function (T) (values list boolean)) function-keywords))
  2866. (defmethod function-keywords ((method standard-method))
  2867.   (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
  2868.       (analyze-lambda-list (method-lambda-list method))
  2869.     (declare (type boolean allow-other-keys-p))
  2870.     (declare (ignore nreq nopt keysp restp))
  2871.     (values keywords allow-other-keys-p)))
  2872.  
  2873. (defun method-ll->generic-function-ll (ll)
  2874.   ;; The generic-function lambda-list is the same as the method-lambda
  2875.   ;; list, except that no default initial values or supplied-p
  2876.   ;; parameters are allowed for optional or keyword arguments, and
  2877.   ;; &aux parameters are not allowed (and therefore removed).
  2878.   (let ((collection NIL))
  2879.     (dolist (element ll)
  2880.       (cond ((listp element)
  2881.              (push (car element) collection))
  2882.             ((eq element '&aux)
  2883.              (return))
  2884.             (T (push element collection))))
  2885.     (nreverse collection)))
  2886.  
  2887.  
  2888. ;;;
  2889. ;;; This is based on the rules of method lambda list congruency defined in
  2890. ;;; the spec.  The lambda list it constructs is the pretty union of the
  2891. ;;; lambda lists of all the methods.  It doesn't take method applicability
  2892. ;;; into account at all yet.
  2893. ;;; 
  2894.  
  2895. (declaim (ftype (function (T) (values list list boolean list boolean))
  2896.                 method-pretty-arglist))
  2897. (defmethod method-pretty-arglist ((method standard-method))
  2898.   (let ((required ())
  2899.     (optional ())
  2900.     (rest-p nil)
  2901.     (key ())
  2902.     (allow-other-keys-p nil)
  2903.     (state 'required)
  2904.     (arglist (method-lambda-list method)))
  2905.     (declare (type boolean rest-p allow-other-keys-p))
  2906.     (dolist (arg arglist)
  2907.       (cond ((eq arg '&optional)         (setq state 'optional))
  2908.         ((eq arg '&rest)             (setq state 'rest))
  2909.         ((eq arg '&key)              (setq state 'key))
  2910.         ((eq arg '&allow-other-keys) (setq allow-other-keys-p 't))
  2911.         ((memq arg lambda-list-keywords))
  2912.         (t
  2913.          (ecase state
  2914.            (required (push arg required))
  2915.            (optional (push arg optional))
  2916.            (key      (push arg key))
  2917.            (rest     (setq rest-p arg))))))
  2918.     (values (nreverse required)
  2919.         (nreverse optional)
  2920.         rest-p
  2921.         (nreverse key)
  2922.         allow-other-keys-p)))
  2923.  
  2924. (defmethod generic-function-pretty-arglist
  2925.        ((generic-function standard-generic-function))
  2926.   (let ((methods (generic-function-methods generic-function))
  2927.     (arglist ()))      
  2928.     (when methods
  2929.       (multiple-value-bind (required optional rest key allow-other-keys)
  2930.       (method-pretty-arglist (car methods))
  2931.     (dolist (m (cdr methods))
  2932.       (multiple-value-bind (method-key-keywords
  2933.                 method-allow-other-keys
  2934.                 method-key)
  2935.           (function-keywords m)
  2936.         ;; we've modified function-keywords to return what we want as
  2937.         ;;  the third value, no other change here.
  2938.         (declare (ignore method-key-keywords))
  2939.         (setq key (union key method-key))
  2940.         (setq allow-other-keys (or allow-other-keys
  2941.                        method-allow-other-keys))))
  2942.     (when allow-other-keys
  2943.       (setq arglist '(&allow-other-keys)))
  2944.     (when key
  2945.       (setq arglist (nconc (list '&key) key arglist)))
  2946.     (when rest
  2947.       (setq arglist (nconc (list '&rest rest) arglist)))
  2948.     (when optional
  2949.       (setq arglist (nconc (list '&optional) optional arglist)))
  2950.     (nconc required arglist)))))
  2951.   
  2952.  
  2953.